Skip to content
Browse files

cabal package wrapper

  • Loading branch information...
1 parent 9302559 commit 00d1d5038205638c39f9cce3273142763eaf1bc3 @dorchard committed
View
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2012, Dominic Orchard
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Jason Dagit nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
View
BIN Language/Haskell/Meta/Parse.hi
Binary file not shown.
View
163 Language/Haskell/Meta/Parse.hs
@@ -1,163 +0,0 @@
-{- |
- Module : Language.Haskell.Meta.Parse
- Copyright : (c) Matt Morrow 2008
- License : BSD3
- Maintainer : Matt Morrow <mjm2002@gmail.com>
- Stability : experimental
- Portability : portable (template-haskell)
--}
-
-module Language.Haskell.Meta.Parse (
- parsePat,
- parseExp,
- parseType,
- parseDecs,
- myDefaultParseMode,
- myDefaultExtensions,
- parseResultToEither,
- parseHsModule,
- parseHsDecls,
- parseHsType,
- parseHsExp,
- parseHsPat,
- pprHsModule,
- moduleDecls,
- emptySrcLoc,
- emptyHsModule
- ) where
-
-import Language.Haskell.TH.Syntax
-import Language.Haskell.Meta.Syntax.Translate
-import qualified Language.Haskell.Exts.Syntax as Hs
-import Language.Haskell.Exts.Annotated.Fixity as Fix
-import Language.Haskell.Exts.Extension
-import Language.Haskell.Exts.Parser hiding (parseExp, parseType, parsePat)
-import Language.Haskell.Exts.Pretty
-
------------------------------------------------------------------------------
-
--- * template-haskell
-
-parsePat :: String -> Either String Pat
-parsePat = either Left (Right . toPat) . parseHsPat
-
-parseExp :: String -> Either String Exp
-parseExp = either Left (Right . toExp) . parseHsExp
-
-parseType :: String -> Either String Type
-parseType = either Left (Right . toType) . parseHsType
-
-parseDecs :: String -> Either String [Dec]
-parseDecs = either Left (Right . toDecs) . parseHsDecls
-
------------------------------------------------------------------------------
-
-{-# DEPRECATED myDefaultParseMode, myDefaultExtensions
- "The provided ParseModes aren't very meaningful, use your own instead" #-}
-myDefaultParseMode :: ParseMode
-myDefaultParseMode = ParseMode
- {parseFilename = []
- ,extensions = myDefaultExtensions
- ,ignoreLinePragmas = False
- ,ignoreLanguagePragmas = False
- ,fixities = defaultFixities}
-
--- This is a silly hack to make things work on haskell-src-exts versions
--- 1.10 and 1.11 simultaneously. I justify it because myDefaultParseMode is
--- deprecated anyway.
---
--- Essentially we want defaultFixities to be baseFixities or Just baseFixities
--- as appropriate. We do this without requiring FlexibleInstances using the
--- same trick as Show on lists does.
-class DefaultFixities a where
- defaultFixities :: a
- defaultFixities =
- error "Language.Haskell.Meta.Parse.defaultFixities undefined"
- defaultFixityList :: [a]
- defaultFixityList =
- error "Language.Haskell.Meta.Parse.defaultFixityList undefined"
-
-instance DefaultFixities Fix.Fixity where
- defaultFixityList = baseFixities
-
-instance DefaultFixities a => DefaultFixities [a] where
- defaultFixities = defaultFixityList
-
-instance DefaultFixities a => DefaultFixities (Maybe a) where
- defaultFixities = Just defaultFixities
-
-myDefaultExtensions :: [Extension]
-myDefaultExtensions = [PostfixOperators
- ,QuasiQuotes
- ,UnicodeSyntax
- ,PatternSignatures
- ,MagicHash
- ,ForeignFunctionInterface
- ,TemplateHaskell
- ,RankNTypes
- ,MultiParamTypeClasses
- ,RecursiveDo]
-
-parseResultToEither :: ParseResult a -> Either String a
-parseResultToEither (ParseOk a) = Right a
-parseResultToEither (ParseFailed loc e)
- = let line = Hs.srcLine loc - 1
- in Left (unlines [show line,show loc,e])
-
-parseHsModule :: String -> Either String Hs.Module
-parseHsModule = parseResultToEither . parseModuleWithMode myDefaultParseMode
-
-parseHsDecls :: String -> Either String [Hs.Decl]
-parseHsDecls = either Left (Right . moduleDecls)
- . parseResultToEither . parseModuleWithMode myDefaultParseMode
-
-
-parseHsType :: String -> Either String Hs.Type
-parseHsType = parseResultToEither . parseTypeWithMode myDefaultParseMode
-
-
-parseHsExp :: String -> Either String Hs.Exp
-parseHsExp = parseResultToEither . parseExpWithMode myDefaultParseMode
-
-parseHsPat :: String -> Either String Hs.Pat
-parseHsPat = parseResultToEither . parsePatWithMode myDefaultParseMode
-
-pprHsModule :: Hs.Module -> String
-pprHsModule = prettyPrint
-
-
-moduleDecls :: Hs.Module -> [Hs.Decl]
-moduleDecls (Hs.Module _ _ _ _ _ _ x) = x
-
--- mkModule :: String -> Hs.Module
--- mkModule s = Hs.Module undefined (Hs.ModuleName s) Nothing [] []
-
-emptySrcLoc :: Hs.SrcLoc
-emptySrcLoc = (Hs.SrcLoc [] 0 0)
-
-emptyHsModule :: String -> Hs.Module
-emptyHsModule n =
- (Hs.Module
- emptySrcLoc
- (Hs.ModuleName n)
- []
- Nothing
- Nothing
- []
- [])
-
-{-
-ghci> :i Module
-data Module
- = Module SrcLoc
- ModuleName
- [OptionPragma]
- (Maybe WarningText)
- (Maybe [ExportSpec])
- [ImportDecl]
- [Decl]
- -- Defined in Language.Haskell.Exts.Syntax
-instance Show Module -- Defined in Language.Haskell.Exts.Syntax
--}
-
------------------------------------------------------------------------------
View
BIN Language/Haskell/Meta/Parse.o
Binary file not shown.
View
BIN Language/Haskell/Meta/Parse/Careful.hi
Binary file not shown.
View
73 Language/Haskell/Meta/Parse/Careful.hs
@@ -1,73 +0,0 @@
-{- |
-This module provides the tools to handle operator fixities in infix expressions correctly.
-
-The problem we solve is the following. Consider making a quasiquoter which antiquotes to Haskell - for instance, the quasiquoter in <http://hackage.haskell.org/package/hmatrix-static> allows me to write
-
-> myVec :: Vector Double
-> myVec = [vec| 2+3*4, 5-4-3 |]
-
-To correctly parse such expressions, we need to know the fixities and precedences of the operators, so that the above is parsed the same way as
-
-> myVec = [vec| 2+(3*4), (5-4)-3 |]
-
-There is a danger, if we are not careful in parsing, that the above expression instead parses as
-
-> myVec = [vec| (2+3)*4, 5-(4-3) |]
-
-which is a surprising bug, and would only be detected through testing at runtime, rather than at compile time.
-
-When this danger arises, we use this \"careful\" module. It handles \"unresolved infix\" expressions such as @2+3*4@ in two ways, depending on the version of GHC:
-
- * in GHC 7.4 and above (where support for \"unresolved infix\" was added in Template Haskell), resolution of the infix expression is deferred to the compiler, which has all fixities available to it.
-
- * prior to GHC 7.4, any ambiguous infix expression is flagged as a parse error at compile time, and the user is advised to resolve the ambiguity by adding parentheses.
-
--}
-module Language.Haskell.Meta.Parse.Careful(
- parsePat,
- parseExp,
- parseType,
- parseDecs
- ) where
-
-import qualified Language.Haskell.Meta.Parse as Sloppy
-import qualified Language.Haskell.Meta.Syntax.Translate as Translate
-import qualified Language.Haskell.TH as TH
-import qualified Language.Haskell.Exts.Syntax as Hs
-#if !(MIN_VERSION_template_haskell(2,7,0))
-import Data.Generics.Uniplate.Data
-#endif
-
-doChecked parser translater p =
- case parser p of
- Left s -> Left s
- Right p' | amb p' -> Left "Infix expression could not be resolved as operator fixities are not known. Resolve ambiguity by adding parentheses"
- | otherwise -> Right (translater p')
-
-parsePat :: String -> Either String TH.Pat
-parsePat = doChecked Sloppy.parseHsPat Translate.toPat
-
-parseExp :: String -> Either String TH.Exp
-parseExp = doChecked Sloppy.parseHsExp Translate.toExp
-
-parseType :: String -> Either String TH.Type
-parseType = doChecked Sloppy.parseHsType Translate.toType
-
-parseDecs :: String -> Either String [TH.Dec]
-parseDecs = doChecked Sloppy.parseHsDecls Translate.toDecs
-
-#if MIN_VERSION_template_haskell(2,7,0)
-amb = const False
-#else
-amb syn = any isAmbExp (universeBi syn) || any isAmbPat (universeBi syn)
- where
- isAmbExp (Hs.InfixApp Hs.InfixApp{} _ _) = True
- isAmbExp (Hs.InfixApp _ _ Hs.InfixApp{}) = True
- isAmbExp (Hs.InfixApp Hs.RightSection{} _ _) = True
- isAmbExp (Hs.InfixApp _ _ Hs.LeftSection{}) = True
- isAmbExp _ = False
-
- isAmbPat (Hs.PInfixApp Hs.PInfixApp{} _ _) = True
- isAmbPat (Hs.PInfixApp _ _ Hs.PInfixApp{}) = True
- isAmbPat _ = False
-#endif
View
BIN Language/Haskell/Meta/Parse/Careful.o
Binary file not shown.
View
BIN Language/Haskell/Meta/Syntax/Translate.hi
Binary file not shown.
View
615 Language/Haskell/Meta/Syntax/Translate.hs
@@ -1,615 +0,0 @@
-{-# LANGUAGE CPP, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}
-
-{- |
- Module : Language.Haskell.Meta.Syntax.Translate
- Copyright : (c) Matt Morrow 2008
- License : BSD3
- Maintainer : Matt Morrow <mjm2002@gmail.com>
- Stability : experimental
- Portability : portable (template-haskell)
--}
-
-module Language.Haskell.Meta.Syntax.Translate (
- module Language.Haskell.Meta.Syntax.Translate
-) where
-
-import Data.Typeable
-import Data.List (foldl', nub, (\\))
-import Language.Haskell.TH.Syntax
-import qualified Language.Haskell.Exts.Syntax as Hs
-
------------------------------------------------------------------------------
-
-
-class ToName a where toName :: a -> Name
-class ToLit a where toLit :: a -> Lit
-class ToType a where toType :: a -> Type
-class ToPat a where toPat :: a -> Pat
-class ToExp a where toExp :: a -> Exp
-class ToDecs a where toDecs :: a -> [Dec]
-class ToDec a where toDec :: a -> Dec
-class ToStmt a where toStmt :: a -> Stmt
-class ToLoc a where toLoc :: a -> Loc
-
--- for error messages
-moduleName = "Language.Haskell.Meta.Syntax.Translate"
-
--- When to use each of these isn't always clear: prefer 'todo' if unsure.
-noTH :: Show e => String -> e -> a
-noTH fun thing = error . concat $ [moduleName, ".", fun,
- ": no TH representation for: ", show thing]
-
-todo :: Show e => String -> e -> a
-todo fun thing = error . concat $ [moduleName, ".", fun,
- ": not implemented: ", show thing]
-
-nonsense :: Show e => String -> String -> e -> a
-nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun,
- ": nonsensical: ", inparticular, ": ", show thing]
-
------------------------------------------------------------------------------
-
-
-instance ToExp Lit where
- toExp = LitE
-instance (ToExp a) => ToExp [a] where
- toExp = ListE . fmap toExp
-instance (ToExp a, ToExp b) => ToExp (a,b) where
- toExp (a,b) = TupE [toExp a, toExp b]
-instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where
- toExp (a,b,c) = TupE [toExp a, toExp b, toExp c]
-instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where
- toExp (a,b,c,d) = TupE [toExp a, toExp b, toExp c, toExp d]
-
-
-instance ToPat Lit where
- toPat = LitP
-instance (ToPat a) => ToPat [a] where
- toPat = ListP . fmap toPat
-instance (ToPat a, ToPat b) => ToPat (a,b) where
- toPat (a,b) = TupP [toPat a, toPat b]
-instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where
- toPat (a,b,c) = TupP [toPat a, toPat b, toPat c]
-instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where
- toPat (a,b,c,d) = TupP [toPat a, toPat b, toPat c, toPat d]
-
-
-instance ToLit Char where
- toLit = CharL
-instance ToLit String where
- toLit = StringL
-instance ToLit Integer where
- toLit = IntegerL
-instance ToLit Int where
- toLit = IntegerL . toInteger
-instance ToLit Float where
- toLit = RationalL . toRational
-instance ToLit Double where
- toLit = RationalL . toRational
-
-
------------------------------------------------------------------------------
-
-
--- * ToName {String,HsName,Module,HsSpecialCon,HsQName}
-
-
-instance ToName String where
- toName = mkName
-
-instance ToName Hs.Name where
- toName (Hs.Ident s) = toName s
- toName (Hs.Symbol s) = toName s
-
-instance ToName Hs.Module where
- toName (Hs.Module _ (Hs.ModuleName s) _ _ _ _ _) = toName s
-
-
-instance ToName Hs.SpecialCon where
- toName Hs.UnitCon = '()
- toName Hs.ListCon = '[]
- toName Hs.FunCon = ''(->)
- toName (Hs.TupleCon _ n)
- | n<2 = '()
- | otherwise =
- let x = maybe [] (++".") (nameModule '(,))
- in mkName . concat $ x : ["(",replicate (n-1) ',',")"]
- toName Hs.Cons = '(:)
-
-
-instance ToName Hs.QName where
--- toName (Hs.Qual (Hs.Module []) n) = toName n
- toName (Hs.Qual (Hs.ModuleName []) n) = toName n
- toName (Hs.Qual (Hs.ModuleName m) n) =
- let m' = show . toName $ m
- n' = show . toName $ n
- in toName . concat $ [m',".",n']
- toName (Hs.UnQual n) = toName n
- toName (Hs.Special s) = toName s
-
-
-
------------------------------------------------------------------------------
-
--- * ToLit HsLiteral
-
-
-instance ToLit Hs.Literal where
- toLit (Hs.Char a) = CharL a
- toLit (Hs.String a) = StringL a
- toLit (Hs.Int a) = IntegerL a
- toLit (Hs.Frac a) = RationalL a
- toLit (Hs.PrimChar a) = CharL a -- XXX
- toLit (Hs.PrimString a) = StringL a -- XXX
- toLit (Hs.PrimInt a) = IntPrimL a
- toLit (Hs.PrimFloat a) = FloatPrimL a
- toLit (Hs.PrimDouble a) = DoublePrimL a
-
------------------------------------------------------------------------------
-
--- * ToPat HsPat
-
-
-instance ToPat Hs.Pat where
- toPat (Hs.PVar n)
- = VarP (toName n)
- toPat (Hs.PLit l)
- = LitP (toLit l)
-{-
-ghci> parseHsPat "-2"
-Right (HsPParen (HsPNeg (HsPLit (HsInt 2))))
--}
- toPat (Hs.PNeg (Hs.PLit l)) = LitP $ case toLit l of
- IntegerL z -> IntegerL (negate z)
- RationalL q -> RationalL (negate q)
- IntPrimL z' -> IntPrimL (negate z')
- FloatPrimL r' -> FloatPrimL (negate r')
- DoublePrimL r'' -> DoublePrimL (negate r'')
- _ -> nonsense "toPat" "negating wrong kind of literal" l
- toPat (Hs.PNeg p) = nonsense "toPat" "negating non-literal" p
- toPat (Hs.PInfixApp p n q) = UInfixP (toPat p) (toName n) (toPat q)
- toPat (Hs.PApp n ps) = ConP (toName n) (fmap toPat ps)
- toPat (Hs.PTuple ps) = TupP (fmap toPat ps)
- toPat (Hs.PList ps) = ListP (fmap toPat ps)
- toPat (Hs.PParen p) = ParensP (toPat p)
- toPat (Hs.PRec n pfs) = let toFieldPat (Hs.PFieldPat n p) = (toName n, toPat p)
- in RecP (toName n) (fmap toFieldPat pfs)
- toPat (Hs.PAsPat n p) = AsP (toName n) (toPat p)
- toPat (Hs.PWildCard) = WildP
- toPat (Hs.PIrrPat p) = TildeP (toPat p)
- toPat (Hs.PatTypeSig _ p t) = SigP (toPat p) (toType t)
- -- regular pattern
- toPat p@Hs.PRPat{} = noTH "toPat" p
- -- XML stuff
- toPat p@Hs.PXTag{} = noTH "toPat" p
- toPat p@Hs.PXETag{} = noTH "toPat" p
- toPat p@Hs.PXPcdata{} = noTH "toPat" p
- toPat p@Hs.PXPatTag{} = noTH "toPat" p
-
------------------------------------------------------------------------------
-
--- * ToExp HsExp
-
-instance ToExp Hs.QOp where
- toExp (Hs.QVarOp n) = VarE (toName n)
- toExp (Hs.QConOp n) = ConE (toName n)
-
-toFieldExp :: Hs.FieldUpdate -> FieldExp
-toFieldExp (Hs.FieldUpdate n e) = (toName n, toExp e)
-
-
-
-
-instance ToExp Hs.Exp where
-{-
-data HsExp
- = HsVar HsQName
--}
--- | HsIPVar HsIPName
-{-
- | HsLet HsBinds HsExp
- | HsDLet [HsIPBind] HsExp
- | HsWith HsExp [HsIPBind]
- | HsCase HsExp [HsAlt]
- | HsDo [HsStmt]
- -- use mfix somehow
- | HsMDo [HsStmt]
--}
- toExp (Hs.Var n) = VarE (toName n)
- toExp (Hs.Con n) = ConE (toName n)
- toExp (Hs.Lit l) = LitE (toLit l)
- toExp (Hs.InfixApp e o f) = UInfixE (toExp e) (toExp o) (toExp f)
- toExp (Hs.LeftSection e o) = InfixE (Just . toExp $ e) (toExp o) Nothing
- toExp (Hs.RightSection o f) = InfixE Nothing (toExp o) (Just . toExp $ f)
- toExp (Hs.App e f) = AppE (toExp e) (toExp f)
- toExp (Hs.NegApp e) = AppE (VarE 'negate) (toExp e)
- toExp (Hs.Lambda _ ps e) = LamE (fmap toPat ps) (toExp e)
- toExp (Hs.Let bs e) = LetE (hsBindsToDecs bs) (toExp e)
- -- toExp (HsWith e bs
- toExp (Hs.If a b c) = CondE (toExp a) (toExp b) (toExp c)
- toExp (Hs.Do ss) = DoE (map toStmt ss)
- -- toExp (HsMDo ss)
- toExp (Hs.Tuple xs) = TupE (fmap toExp xs)
- toExp (Hs.List xs) = ListE (fmap toExp xs)
- toExp (Hs.Paren e) = ParensE (toExp e)
- toExp (Hs.RecConstr n xs) = RecConE (toName n) (fmap toFieldExp xs)
- toExp (Hs.RecUpdate e xs) = RecUpdE (toExp e) (fmap toFieldExp xs)
- toExp (Hs.EnumFrom e) = ArithSeqE $ FromR (toExp e)
- toExp (Hs.EnumFromTo e f) = ArithSeqE $ FromToR (toExp e) (toExp f)
- toExp (Hs.EnumFromThen e f) = ArithSeqE $ FromThenR (toExp e) (toExp f)
- toExp (Hs.EnumFromThenTo e f g) = ArithSeqE $ FromThenToR (toExp e) (toExp f) (toExp g)
- toExp (Hs.ExpTypeSig _ e t) = SigE (toExp e) (toType t)
- -- HsListComp HsExp [HsStmt]
- -- toExp (HsListComp e ss) = CompE
- -- NEED: a way to go e -> Stmt
-{- HsVarQuote HsQName
- | HsTypQuote HsQName
- | HsBracketExp HsBracket
- | HsSpliceExp HsSplice
-data HsBracket
- = HsExpBracket HsExp
- | HsPatBracket HsPat
- | HsTypeBracket HsType
- | HsDeclBracket [HsDecl]
-data HsSplice = HsIdSplice String | HsParenSplice HsExp -}
- toExp (Hs.Case e alts) = CaseE (toExp e) (map toMatch alts)
- toExp e = todo "toExp" e
-
-
-toMatch :: Hs.Alt -> Match
-toMatch (Hs.Alt _ p galts ds) = Match (toPat p) (toBody galts) (toDecs ds)
-
-toBody :: Hs.GuardedAlts -> Body
-toBody (Hs.UnGuardedAlt e) = NormalB $ toExp e
-toBody (Hs.GuardedAlts alts) = GuardedB $ do
- Hs.GuardedAlt _ stmts e <- alts
- let
- g = case map toStmt stmts of
- [NoBindS x] -> NormalG x
- xs -> PatG xs
- return (g, toExp e)
-
-toGuard (Hs.GuardedAlt _ ([Hs.Qualifier e1]) e2) = (NormalG $ toExp e1,toExp e2)
-
------------------------------------------------------------------------------
-
-{-
-class ToName a where toName :: a -> Name
-class ToLit a where toLit :: a -> Lit
-class ToType a where toType :: a -> Type
-class ToPat a where toPat :: a -> Pat
-class ToExp a where toExp :: a -> Exp
-class ToDec a where toDec :: a -> Dec
-class ToStmt a where toStmt :: a -> Stmt
-class ToLoc a where toLoc :: a -> Loc
--}
-
-{-
-TODO:
- []
-
-PARTIAL:
- * ToExp HsExp
- * ToStmt HsStmt
- * ToDec HsDecl
-
-DONE:
- * ToLit HsLiteral
- * ToName {..}
- * ToPat HsPat
- * ToLoc SrcLoc
- * ToType HsType
-
--}
------------------------------------------------------------------------------
-
--- * ToLoc SrcLoc
-
-instance ToLoc Hs.SrcLoc where
- toLoc (Hs.SrcLoc fn l c) =
- Loc fn [] [] (l,c) (-1,-1)
-
------------------------------------------------------------------------------
-
--- * ToType HsType
-
-instance ToName Hs.TyVarBind where
- toName (Hs.KindedVar n _) = toName n
- toName (Hs.UnkindedVar n) = toName n
-
-instance ToName Name where
- toName = id
-
-toKind :: Hs.Kind -> Kind
-toKind Hs.KindStar = StarK
-toKind (Hs.KindFn k1 k2) = ArrowK (toKind k1) (toKind k2)
-toKind (Hs.KindParen kp) = toKind kp
-toKind k@Hs.KindBang = noTH "toKind" k
-toKind k@Hs.KindVar{} = noTH "toKind" k
-
-toTyVar :: Hs.TyVarBind -> TyVarBndr
-toTyVar (Hs.KindedVar n k) = KindedTV (toName n) (toKind k)
-toTyVar (Hs.UnkindedVar n) = PlainTV (toName n)
-
-{- |
-TH does't handle
- * unboxed tuples
- * implicit params
- * infix type constructors
- * kind signatures
--}
-instance ToType Hs.Type where
- toType (Hs.TyForall tvbM cxt t) = ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t)
- toType (Hs.TyFun a b) = toType a .->. toType b
- toType (Hs.TyList t) = ListT `AppT` toType t
- toType (Hs.TyTuple _ ts) = foldAppT (TupleT . length $ ts) (fmap toType ts)
- toType (Hs.TyApp a b) = AppT (toType a) (toType b)
- toType (Hs.TyVar n) = VarT (toName n)
- toType (Hs.TyCon qn) = ConT (toName qn)
- toType (Hs.TyParen t) = toType t
- -- XXX: need to wrap the name in parens!
- toType (Hs.TyInfix a o b) = AppT (AppT (ConT (toName o)) (toType a)) (toType b)
- toType (Hs.TyKind t _) = toType t
-
-
-
-
-(.->.) :: Type -> Type -> Type
-a .->. b = AppT (AppT ArrowT a) b
-
-{- |
-TH doesn't handle:
- * implicit params
--}
-
-toCxt :: Hs.Context -> Cxt
-toCxt = fmap toPred
- where
- toPred (Hs.ClassA n ts) = ClassP (toName n) (fmap toType ts)
- toPred (Hs.InfixA t1 n t2) = ClassP (toName n) (fmap toType [t1, t2])
- toPred (Hs.EqualP t1 t2) = EqualP (toType t1) (toType t2)
- toPred a@Hs.IParam{} = noTH "toCxt" a
-
-
-foldAppT :: Type -> [Type] -> Type
-foldAppT t ts = foldl' AppT t ts
-
------------------------------------------------------------------------------
-
--- * ToStmt HsStmt
-
-instance ToStmt Hs.Stmt where
- toStmt (Hs.Generator _ p e) = BindS (toPat p) (toExp e)
- toStmt (Hs.Qualifier e) = NoBindS (toExp e)
- toStmt a@(Hs.LetStmt bnds) = LetS (hsBindsToDecs bnds)
-
-
------------------------------------------------------------------------------
-
--- * ToDec HsDecl
-
--- data HsBinds = HsBDecls [HsDecl] | HsIPBinds [HsIPBind]
-hsBindsToDecs :: Hs.Binds -> [Dec]
-hsBindsToDecs (Hs.BDecls ds) = fmap toDec ds
-hsBindsToDecs a@Hs.IPBinds{} = noTH "hsBindsToDecs" a
--- data HsIPBind = HsIPBind SrcLoc HsIPName HsExp
-
-
-hsBangTypeToStrictType :: Hs.BangType -> (Strict, Type)
-hsBangTypeToStrictType (Hs.BangedTy t) = (IsStrict, toType t)
-hsBangTypeToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)
-
-
-{-
-data HsTyVarBind = HsKindedVar HsName HsKind | HsUnkindedVar HsName
-data HsConDecl
- = HsConDecl HsName [HsBangType]
- | HsRecDecl HsName [([HsName], HsBangType)]
--}
-{-
-hsQualConDeclToCon :: HsQualConDecl -> Con
-hsQualConDeclToCon (HsQualConDecl _ tvbs cxt condec) =
- case condec of
- HsConDecl n bangs ->
- HsRecDecl n assocs ->
--}
-
-
-
-
-instance ToDec Hs.Decl where
- toDec (Hs.TypeDecl _ n ns t)
- = TySynD (toName n) (fmap toTyVar ns) (toType t)
-
-
- toDec a@(Hs.DataDecl _ dOrN cxt n ns qcds qns)
- = case dOrN of
- Hs.DataType -> DataD (toCxt cxt)
- (toName n)
- (fmap toTyVar ns)
- (fmap qualConDeclToCon qcds)
- (fmap (toName . fst) qns)
- Hs.NewType -> let qcd = case qcds of
- [x] -> x
- _ -> nonsense "toDec" ("newtype with " ++
- "wrong number of constructors") dOrN
- in NewtypeD (toCxt cxt)
- (toName n)
- (fmap toTyVar ns)
- (qualConDeclToCon qcd)
- (fmap (toName . fst) qns)
-
--- data Hs.BangType
--- = Hs.BangedTy Hs.Type
--- | Hs.UnBangedTy Hs.Type
--- | Hs.UnpackedTy Hs.Type
--- data Hs.TyVarBind
--- = Hs.KindedVar Hs.Name Hs.Kind | Hs.UnkindedVar Hs.Name
--- data Hs.DataOrNew = Hs.DataType | Hs.NewType
--- data Hs.QualConDecl
--- = Hs.QualConDecl Hs.SrcLoc [Hs.TyVarBind] Hs.Context Hs.ConDecl
--- data Hs.ConDecl
--- = Hs.ConDecl Hs.Name [Hs.BangType]
--- | Hs.RecDecl Hs.Name [([Hs.Name], Hs.BangType)]
-
--- data Con
--- = NormalC Name [StrictType]
--- | RecC Name [VarStrictType]
--- | InfixC StrictType Name StrictType
--- | ForallC [Name] Cxt Con
--- type StrictType = (Strict, Type)
--- type VarStrictType = (Name, Strict, Type)
-
-
- -- This type-signature conversion is just wrong.
- -- Type variables need to be dealt with. /Jonas
- toDec a@(Hs.TypeSig _ ns t)
- -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class!
- = let xs = fmap (flip SigD (toType t) . toName) ns
- in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!"
-
-{- data HsDecl = ... | HsFunBind [HsMatch] | ...
-data HsMatch = HsMatch SrcLoc HsName [HsPat] HsRhs HsBinds
-data Dec = FunD Name [Clause] | ...
-data Clause = Clause [Pat] Body [Dec] -}
- toDec a@(Hs.FunBind mtchs) = hsMatchesToFunD mtchs
-{- ghci> parseExp "let x = 2 in x"
-LetE [ValD (VarP x) (NormalB (LitE (IntegerL 2))) []] (VarE x)
-ghci> unQ[| let x = 2 in x |]
-LetE [ValD (VarP x_0) (NormalB (LitE (IntegerL 2))) []] (VarE x_0) -}
- toDec (Hs.PatBind _ p tM rhs bnds) = ValD ((maybe id
- (flip SigP . toType)
- tM) (toPat p))
- (hsRhsToBody rhs)
- (hsBindsToDecs bnds)
-
- toDec (Hs.InstDecl _ cxt qname ts ids) = InstanceD
- (toCxt cxt)
- (foldl AppT (ConT (toName qname)) (map toType ts))
- (toDecs ids)
-
- toDec x = todo "toDec" x
-
-
--- data Hs.Decl = ... | Hs.SpliceDecl Hs.SrcLoc Hs.Splice | ...
--- data Hs.Splice = Hs.IdSplice String | Hs.ParenSplice Hs.Exp
-
-transAct act = case act of
- Hs.AlwaysActive -> Nothing
- Hs.ActiveFrom n -> Just (True,n)
- Hs.ActiveUntil n -> Just (False,n)
-
-
-
-
-
-
-
-
-qualConDeclToCon :: Hs.QualConDecl -> Con
-qualConDeclToCon (Hs.QualConDecl _ [] [] cdecl) = conDeclToCon cdecl
-qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (fmap toTyVar ns)
- (toCxt cxt)
- (conDeclToCon cdecl)
-
-conDeclToCon :: Hs.ConDecl -> Con
-conDeclToCon (Hs.ConDecl n tys)
- = NormalC (toName n) (fmap bangToStrictType tys)
-conDeclToCon (Hs.RecDecl n lbls)
- = RecC (toName n) (concatMap (uncurry bangToVarStrictTypes) lbls)
-
-
-
-bangToVarStrictTypes :: [Hs.Name] -> Hs.BangType -> [VarStrictType]
-bangToVarStrictTypes ns t = let (a,b) = bangToStrictType t
- in fmap (\n->(toName n,a,b)) ns
-
-bangToStrictType :: Hs.BangType -> StrictType
-bangToStrictType (Hs.BangedTy t) = (IsStrict, toType t)
-bangToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)
-bangToStrictType (Hs.UnpackedTy t) = (IsStrict, toType t)
-
-
-hsMatchesToFunD :: [Hs.Match] -> Dec
-hsMatchesToFunD [] = FunD (mkName []) [] -- errorish
-hsMatchesToFunD xs@(Hs.Match _ n _ _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs)
-
-
-hsMatchToClause :: Hs.Match -> Clause
-hsMatchToClause (Hs.Match _ _ ps _ rhs bnds) = Clause
- (fmap toPat ps)
- (hsRhsToBody rhs)
- (hsBindsToDecs bnds)
-
-
-
--- data HsRhs = HsUnGuardedRhs HsExp | HsGuardedRhs [HsGuardedRhs]
--- data HsGuardedRhs = HsGuardedRhs SrcLoc [HsStmt] HsExp
--- data Body = GuardedB [(Guard, Exp)] | NormalB Exp
--- data Guard = NormalG Exp | PatG [Stmt]
-hsRhsToBody :: Hs.Rhs -> Body
-hsRhsToBody (Hs.UnGuardedRhs e) = NormalB (toExp e)
-hsRhsToBody (Hs.GuardedRhss hsgrhs) = let fromGuardedB (GuardedB a) = a
- in GuardedB . concat
- . fmap (fromGuardedB . hsGuardedRhsToBody)
- $ hsgrhs
-
-
-
-hsGuardedRhsToBody :: Hs.GuardedRhs -> Body
-hsGuardedRhsToBody (Hs.GuardedRhs _ [] e) = NormalB (toExp e)
-hsGuardedRhsToBody (Hs.GuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)]
-hsGuardedRhsToBody (Hs.GuardedRhs _ ss e) = let ss' = fmap hsStmtToGuard ss
- (pgs,ngs) = unzip [(p,n)
- | (PatG p) <- ss'
- , n@(NormalG _) <- ss']
- e' = toExp e
- patg = PatG (concat pgs)
- in GuardedB $ (patg,e') : zip ngs (repeat e')
-
-
-
-hsStmtToGuard :: Hs.Stmt -> Guard
-hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)]
-hsStmtToGuard (Hs.Qualifier e) = NormalG (toExp e)
-hsStmtToGuard (Hs.LetStmt bs) = PatG [LetS (hsBindsToDecs bs)]
-
-
------------------------------------------------------------------------------
-
--- * ToDecs InstDecl
-instance ToDecs Hs.InstDecl where
- toDecs (Hs.InsDecl decl) = toDecs decl
- toDecs d = todo "toDec" d
-
--- * ToDecs HsDecl HsBinds
-
-instance ToDecs Hs.Decl where
--- toDecs a@(Hs.InfixDecl _ asst i ops) = [] -- HACK
--- toDecs (Hs.InlineSig _ _ _ _) = [] -- HACK
- toDecs a@(Hs.TypeSig _ ns t)
- = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns
- in xs
-
-
- toDecs a = [toDec a]
-
-collectVars e = case e of
- VarT n -> [PlainTV n]
- AppT t1 t2 -> nub $ collectVars t1 ++ collectVars t2
- ForallT ns _ t -> collectVars t \\ ns
- _ -> []
-
-fixForall t = case vs of
- [] -> t
- _ -> ForallT vs [] t
- where vs = collectVars t
-
-instance ToDecs a => ToDecs [a] where
- toDecs a = concatMap toDecs a
-
-instance ToDecs Hs.Binds where
- toDecs (Hs.BDecls ds) = toDecs ds
-
-
------------------------------------------------------------------------------
View
608 Language/Haskell/Meta/Syntax/Translate.hs~
@@ -1,608 +0,0 @@
-{-# LANGUAGE CPP, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}
-
-{- |
- Module : Language.Haskell.Meta.Syntax.Translate
- Copyright : (c) Matt Morrow 2008
- License : BSD3
- Maintainer : Matt Morrow <mjm2002@gmail.com>
- Stability : experimental
- Portability : portable (template-haskell)
--}
-
-module Language.Haskell.Meta.Syntax.Translate (
- module Language.Haskell.Meta.Syntax.Translate
-) where
-
-import Data.Typeable
-import Data.List (foldl', nub, (\\))
-import Language.Haskell.TH.Syntax
-import qualified Language.Haskell.Exts.Syntax as Hs
-
------------------------------------------------------------------------------
-
-
-class ToName a where toName :: a -> Name
-class ToLit a where toLit :: a -> Lit
-class ToType a where toType :: a -> Type
-class ToPat a where toPat :: a -> Pat
-class ToExp a where toExp :: a -> Exp
-class ToDecs a where toDecs :: a -> [Dec]
-class ToDec a where toDec :: a -> Dec
-class ToStmt a where toStmt :: a -> Stmt
-class ToLoc a where toLoc :: a -> Loc
-
--- for error messages
-moduleName = "Language.Haskell.Meta.Syntax.Translate"
-
--- When to use each of these isn't always clear: prefer 'todo' if unsure.
-noTH :: Show e => String -> e -> a
-noTH fun thing = error . concat $ [moduleName, ".", fun,
- ": no TH representation for: ", show thing]
-
-todo :: Show e => String -> e -> a
-todo fun thing = error . concat $ [moduleName, ".", fun,
- ": not implemented: ", show thing]
-
-nonsense :: Show e => String -> String -> e -> a
-nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun,
- ": nonsensical: ", inparticular, ": ", show thing]
-
------------------------------------------------------------------------------
-
-
-instance ToExp Lit where
- toExp = LitE
-instance (ToExp a) => ToExp [a] where
- toExp = ListE . fmap toExp
-instance (ToExp a, ToExp b) => ToExp (a,b) where
- toExp (a,b) = TupE [toExp a, toExp b]
-instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where
- toExp (a,b,c) = TupE [toExp a, toExp b, toExp c]
-instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where
- toExp (a,b,c,d) = TupE [toExp a, toExp b, toExp c, toExp d]
-
-
-instance ToPat Lit where
- toPat = LitP
-instance (ToPat a) => ToPat [a] where
- toPat = ListP . fmap toPat
-instance (ToPat a, ToPat b) => ToPat (a,b) where
- toPat (a,b) = TupP [toPat a, toPat b]
-instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where
- toPat (a,b,c) = TupP [toPat a, toPat b, toPat c]
-instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where
- toPat (a,b,c,d) = TupP [toPat a, toPat b, toPat c, toPat d]
-
-
-instance ToLit Char where
- toLit = CharL
-instance ToLit String where
- toLit = StringL
-instance ToLit Integer where
- toLit = IntegerL
-instance ToLit Int where
- toLit = IntegerL . toInteger
-instance ToLit Float where
- toLit = RationalL . toRational
-instance ToLit Double where
- toLit = RationalL . toRational
-
-
------------------------------------------------------------------------------
-
-
--- * ToName {String,HsName,Module,HsSpecialCon,HsQName}
-
-
-instance ToName String where
- toName = mkName
-
-instance ToName Hs.Name where
- toName (Hs.Ident s) = toName s
- toName (Hs.Symbol s) = toName s
-
-instance ToName Hs.Module where
- toName (Hs.Module _ (Hs.ModuleName s) _ _ _ _ _) = toName s
-
-
-instance ToName Hs.SpecialCon where
- toName Hs.UnitCon = '()
- toName Hs.ListCon = '[]
- toName Hs.FunCon = ''(->)
- toName (Hs.TupleCon _ n)
- | n<2 = '()
- | otherwise =
- let x = maybe [] (++".") (nameModule '(,))
- in mkName . concat $ x : ["(",replicate (n-1) ',',")"]
- toName Hs.Cons = '(:)
-
-
-instance ToName Hs.QName where
--- toName (Hs.Qual (Hs.Module []) n) = toName n
- toName (Hs.Qual (Hs.ModuleName []) n) = toName n
- toName (Hs.Qual (Hs.ModuleName m) n) =
- let m' = show . toName $ m
- n' = show . toName $ n
- in toName . concat $ [m',".",n']
- toName (Hs.UnQual n) = toName n
- toName (Hs.Special s) = toName s
-
-
-
------------------------------------------------------------------------------
-
--- * ToLit HsLiteral
-
-
-instance ToLit Hs.Literal where
- toLit (Hs.Char a) = CharL a
- toLit (Hs.String a) = StringL a
- toLit (Hs.Int a) = IntegerL a
- toLit (Hs.Frac a) = RationalL a
- toLit (Hs.PrimChar a) = CharL a -- XXX
- toLit (Hs.PrimString a) = StringL a -- XXX
- toLit (Hs.PrimInt a) = IntPrimL a
- toLit (Hs.PrimFloat a) = FloatPrimL a
- toLit (Hs.PrimDouble a) = DoublePrimL a
-
------------------------------------------------------------------------------
-
--- * ToPat HsPat
-
-
-instance ToPat Hs.Pat where
- toPat (Hs.PVar n)
- = VarP (toName n)
- toPat (Hs.PLit l)
- = LitP (toLit l)
-{-
-ghci> parseHsPat "-2"
-Right (HsPParen (HsPNeg (HsPLit (HsInt 2))))
--}
- toPat (Hs.PNeg (Hs.PLit l)) = LitP $ case toLit l of
- IntegerL z -> IntegerL (negate z)
- RationalL q -> RationalL (negate q)
- IntPrimL z' -> IntPrimL (negate z')
- FloatPrimL r' -> FloatPrimL (negate r')
- DoublePrimL r'' -> DoublePrimL (negate r'')
- _ -> nonsense "toPat" "negating wrong kind of literal" l
- toPat (Hs.PNeg p) = nonsense "toPat" "negating non-literal" p
- toPat (Hs.PInfixApp p n q) = UInfixP (toPat p) (toName n) (toPat q)
- toPat (Hs.PApp n ps) = ConP (toName n) (fmap toPat ps)
- toPat (Hs.PTuple ps) = TupP (fmap toPat ps)
- toPat (Hs.PList ps) = ListP (fmap toPat ps)
- toPat (Hs.PParen p) = ParensP (toPat p)
- toPat (Hs.PRec n pfs) = let toFieldPat (Hs.PFieldPat n p) = (toName n, toPat p)
- in RecP (toName n) (fmap toFieldPat pfs)
- toPat (Hs.PAsPat n p) = AsP (toName n) (toPat p)
- toPat (Hs.PWildCard) = WildP
- toPat (Hs.PIrrPat p) = TildeP (toPat p)
- toPat (Hs.PatTypeSig _ p t) = SigP (toPat p) (toType t)
- -- regular pattern
- toPat p@Hs.PRPat{} = noTH "toPat" p
- -- XML stuff
- toPat p@Hs.PXTag{} = noTH "toPat" p
- toPat p@Hs.PXETag{} = noTH "toPat" p
- toPat p@Hs.PXPcdata{} = noTH "toPat" p
- toPat p@Hs.PXPatTag{} = noTH "toPat" p
-
------------------------------------------------------------------------------
-
--- * ToExp HsExp
-
-instance ToExp Hs.QOp where
- toExp (Hs.QVarOp n) = VarE (toName n)
- toExp (Hs.QConOp n) = ConE (toName n)
-
-toFieldExp :: Hs.FieldUpdate -> FieldExp
-toFieldExp (Hs.FieldUpdate n e) = (toName n, toExp e)
-
-
-
-
-instance ToExp Hs.Exp where
-{-
-data HsExp
- = HsVar HsQName
--}
--- | HsIPVar HsIPName
-{-
- | HsLet HsBinds HsExp
- | HsDLet [HsIPBind] HsExp
- | HsWith HsExp [HsIPBind]
- | HsCase HsExp [HsAlt]
- | HsDo [HsStmt]
- -- use mfix somehow
- | HsMDo [HsStmt]
--}
- toExp (Hs.Var n) = VarE (toName n)
- toExp (Hs.Con n) = ConE (toName n)
- toExp (Hs.Lit l) = LitE (toLit l)
- toExp (Hs.InfixApp e o f) = UInfixE (toExp e) (toExp o) (toExp f)
- toExp (Hs.LeftSection e o) = InfixE (Just . toExp $ e) (toExp o) Nothing
- toExp (Hs.RightSection o f) = InfixE Nothing (toExp o) (Just . toExp $ f)
- toExp (Hs.App e f) = AppE (toExp e) (toExp f)
- toExp (Hs.NegApp e) = AppE (VarE 'negate) (toExp e)
- toExp (Hs.Lambda _ ps e) = LamE (fmap toPat ps) (toExp e)
- toExp (Hs.Let bs e) = LetE (hsBindsToDecs bs) (toExp e)
- -- toExp (HsWith e bs
- toExp (Hs.If a b c) = CondE (toExp a) (toExp b) (toExp c)
- toExp (Hs.Do ss) = DoE (map toStmt ss)
- -- toExp (HsMDo ss)
- toExp (Hs.Tuple xs) = TupE (fmap toExp xs)
- toExp (Hs.List xs) = ListE (fmap toExp xs)
- toExp (Hs.Paren e) = ParensE (toExp e)
- toExp (Hs.RecConstr n xs) = RecConE (toName n) (fmap toFieldExp xs)
- toExp (Hs.RecUpdate e xs) = RecUpdE (toExp e) (fmap toFieldExp xs)
- toExp (Hs.EnumFrom e) = ArithSeqE $ FromR (toExp e)
- toExp (Hs.EnumFromTo e f) = ArithSeqE $ FromToR (toExp e) (toExp f)
- toExp (Hs.EnumFromThen e f) = ArithSeqE $ FromThenR (toExp e) (toExp f)
- toExp (Hs.EnumFromThenTo e f g) = ArithSeqE $ FromThenToR (toExp e) (toExp f) (toExp g)
- toExp (Hs.ExpTypeSig _ e t) = SigE (toExp e) (toType t)
- -- HsListComp HsExp [HsStmt]
- -- toExp (HsListComp e ss) = CompE
- -- NEED: a way to go e -> Stmt
-{- HsVarQuote HsQName
- | HsTypQuote HsQName
- | HsBracketExp HsBracket
- | HsSpliceExp HsSplice
-data HsBracket
- = HsExpBracket HsExp
- | HsPatBracket HsPat
- | HsTypeBracket HsType
- | HsDeclBracket [HsDecl]
-data HsSplice = HsIdSplice String | HsParenSplice HsExp -}
- toExp (Hs.Case e alts) = CaseE (toExp e) (map toMatch alts)
- toExp e = todo "toExp" e
-
-
-toMatch :: Hs.Alt -> Match
-toMatch (Hs.Alt _ p galts ds) = Match (toPat p) (toBody galts) (toDecs ds)
-
-toBody :: Hs.GuardedAlts -> Body
-toBody (Hs.UnGuardedAlt e) = NormalB $ toExp e
-toBody (Hs.GuardedAlts alts) = GuardedB $ do
- Hs.GuardedAlt _ stmts e <- alts
- let
- g = case map toStmt stmts of
- [NoBindS x] -> NormalG x
- xs -> PatG xs
- return (g, toExp e)
-
-toGuard (Hs.GuardedAlt _ ([Hs.Qualifier e1]) e2) = (NormalG $ toExp e1,toExp e2)
-
------------------------------------------------------------------------------
-
-{-
-class ToName a where toName :: a -> Name
-class ToLit a where toLit :: a -> Lit
-class ToType a where toType :: a -> Type
-class ToPat a where toPat :: a -> Pat
-class ToExp a where toExp :: a -> Exp
-class ToDec a where toDec :: a -> Dec
-class ToStmt a where toStmt :: a -> Stmt
-class ToLoc a where toLoc :: a -> Loc
--}
-
-{-
-TODO:
- []
-
-PARTIAL:
- * ToExp HsExp
- * ToStmt HsStmt
- * ToDec HsDecl
-
-DONE:
- * ToLit HsLiteral
- * ToName {..}
- * ToPat HsPat
- * ToLoc SrcLoc
- * ToType HsType
-
--}
------------------------------------------------------------------------------
-
--- * ToLoc SrcLoc
-
-instance ToLoc Hs.SrcLoc where
- toLoc (Hs.SrcLoc fn l c) =
- Loc fn [] [] (l,c) (-1,-1)
-
------------------------------------------------------------------------------
-
--- * ToType HsType
-
-instance ToName Hs.TyVarBind where
- toName (Hs.KindedVar n _) = toName n
- toName (Hs.UnkindedVar n) = toName n
-
-instance ToName Name where
- toName = id
-
-toTyVar :: Hs.TyVarBind -> Name
-toTyVar (Hs.KindedVar n _) = toName n
-toTyVar (Hs.UnkindedVar n) = toName n
-
-{- |
-TH does't handle
- * unboxed tuples
- * implicit params
- * infix type constructors
- * kind signatures
--}
-instance ToType Hs.Type where
- toType (Hs.TyForall tvbM cxt t) = ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t)
- toType (Hs.TyFun a b) = toType a .->. toType b
- toType (Hs.TyList t) = ListT `AppT` toType t
- toType (Hs.TyTuple _ ts) = foldAppT (TupleT . length $ ts) (fmap toType ts)
- toType (Hs.TyApp a b) = AppT (toType a) (toType b)
- toType (Hs.TyVar n) = VarT (toName n)
- toType (Hs.TyCon qn) = ConT (toName qn)
- toType (Hs.TyParen t) = toType t
- -- XXX: need to wrap the name in parens!
- toType (Hs.TyInfix a o b) = AppT (AppT (ConT (toName o)) (toType a)) (toType b)
- toType (Hs.TyKind t _) = toType t
-
-
-
-
-(.->.) :: Type -> Type -> Type
-a .->. b = AppT (AppT ArrowT a) b
-
-{- |
-TH doesn't handle:
- * implicit params
--}
-
-toCxt :: Hs.Context -> Cxt
-toCxt = fmap toPred
- where
- toPred (Hs.ClassA n ts) = foldAppT (ConT (toName n)) (fmap toType ts)
- toPred (Hs.InfixA t1 n t2) = foldAppT (ConT (toName n)) (fmap toType [t1, t2])
- toPred a@Hs.EqualP{} = noTH "toCxt" a
- toPred a@Hs.IParam{} = noTH "toCxt" a
-
-
-foldAppT :: Type -> [Type] -> Type
-foldAppT t ts = foldl' AppT t ts
-
------------------------------------------------------------------------------
-
--- * ToStmt HsStmt
-
-instance ToStmt Hs.Stmt where
- toStmt (Hs.Generator _ p e) = BindS (toPat p) (toExp e)
- toStmt (Hs.Qualifier e) = NoBindS (toExp e)
- toStmt a@(Hs.LetStmt bnds) = LetS (hsBindsToDecs bnds)
-
-
------------------------------------------------------------------------------
-
--- * ToDec HsDecl
-
--- data HsBinds = HsBDecls [HsDecl] | HsIPBinds [HsIPBind]
-hsBindsToDecs :: Hs.Binds -> [Dec]
-hsBindsToDecs (Hs.BDecls ds) = fmap toDec ds
-hsBindsToDecs a@Hs.IPBinds{} = noTH "hsBindsToDecs" a
--- data HsIPBind = HsIPBind SrcLoc HsIPName HsExp
-
-
-hsBangTypeToStrictType :: Hs.BangType -> (Strict, Type)
-hsBangTypeToStrictType (Hs.BangedTy t) = (IsStrict, toType t)
-hsBangTypeToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)
-
-
-{-
-data HsTyVarBind = HsKindedVar HsName HsKind | HsUnkindedVar HsName
-data HsConDecl
- = HsConDecl HsName [HsBangType]
- | HsRecDecl HsName [([HsName], HsBangType)]
--}
-{-
-hsQualConDeclToCon :: HsQualConDecl -> Con
-hsQualConDeclToCon (HsQualConDecl _ tvbs cxt condec) =
- case condec of
- HsConDecl n bangs ->
- HsRecDecl n assocs ->
--}
-
-
-
-
-instance ToDec Hs.Decl where
- toDec (Hs.TypeDecl _ n ns t)
- = TySynD (toName n) (fmap toTyVar ns) (toType t)
-
-
- toDec a@(Hs.DataDecl _ dOrN cxt n ns qcds qns)
- = case dOrN of
- Hs.DataType -> DataD (toCxt cxt)
- (toName n)
- (fmap toTyVar ns)
- (fmap qualConDeclToCon qcds)
- (fmap (toName . fst) qns)
- Hs.NewType -> let qcd = case qcds of
- [x] -> x
- _ -> nonsense "toDec" ("newtype with " ++
- "wrong number of constructors") dOrN
- in NewtypeD (toCxt cxt)
- (toName n)
- (fmap toTyVar ns)
- (qualConDeclToCon qcd)
- (fmap (toName . fst) qns)
-
--- data Hs.BangType
--- = Hs.BangedTy Hs.Type
--- | Hs.UnBangedTy Hs.Type
--- | Hs.UnpackedTy Hs.Type
--- data Hs.TyVarBind
--- = Hs.KindedVar Hs.Name Hs.Kind | Hs.UnkindedVar Hs.Name
--- data Hs.DataOrNew = Hs.DataType | Hs.NewType
--- data Hs.QualConDecl
--- = Hs.QualConDecl Hs.SrcLoc [Hs.TyVarBind] Hs.Context Hs.ConDecl
--- data Hs.ConDecl
--- = Hs.ConDecl Hs.Name [Hs.BangType]
--- | Hs.RecDecl Hs.Name [([Hs.Name], Hs.BangType)]
-
--- data Con
--- = NormalC Name [StrictType]
--- | RecC Name [VarStrictType]
--- | InfixC StrictType Name StrictType
--- | ForallC [Name] Cxt Con
--- type StrictType = (Strict, Type)
--- type VarStrictType = (Name, Strict, Type)
-
-
- -- This type-signature conversion is just wrong.
- -- Type variables need to be dealt with. /Jonas
- toDec a@(Hs.TypeSig _ ns t)
- -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class!
- = let xs = fmap (flip SigD (toType t) . toName) ns
- in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!"
-
-{- data HsDecl = ... | HsFunBind [HsMatch] | ...
-data HsMatch = HsMatch SrcLoc HsName [HsPat] HsRhs HsBinds
-data Dec = FunD Name [Clause] | ...
-data Clause = Clause [Pat] Body [Dec] -}
- toDec a@(Hs.FunBind mtchs) = hsMatchesToFunD mtchs
-{- ghci> parseExp "let x = 2 in x"
-LetE [ValD (VarP x) (NormalB (LitE (IntegerL 2))) []] (VarE x)
-ghci> unQ[| let x = 2 in x |]
-LetE [ValD (VarP x_0) (NormalB (LitE (IntegerL 2))) []] (VarE x_0) -}
- toDec (Hs.PatBind _ p tM rhs bnds) = ValD ((maybe id
- (flip SigP . toType)
- tM) (toPat p))
- (hsRhsToBody rhs)
- (hsBindsToDecs bnds)
-
- toDec (Hs.InstDecl _ cxt qname ts ids) = InstanceD
- (toCxt cxt)
- (foldl AppT (ConT (toName qname)) (map toType ts))
- (toDecs ids)
-
- toDec x = todo "toDec" x
-
-
--- data Hs.Decl = ... | Hs.SpliceDecl Hs.SrcLoc Hs.Splice | ...
--- data Hs.Splice = Hs.IdSplice String | Hs.ParenSplice Hs.Exp
-
-transAct act = case act of
- Hs.AlwaysActive -> Nothing
- Hs.ActiveFrom n -> Just (True,n)
- Hs.ActiveUntil n -> Just (False,n)
-
-
-
-
-
-
-
-
-qualConDeclToCon :: Hs.QualConDecl -> Con
-qualConDeclToCon (Hs.QualConDecl _ [] [] cdecl) = conDeclToCon cdecl
-qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (fmap toTyVar ns)
- (toCxt cxt)
- (conDeclToCon cdecl)
-
-conDeclToCon :: Hs.ConDecl -> Con
-conDeclToCon (Hs.ConDecl n tys)
- = NormalC (toName n) (fmap bangToStrictType tys)
-conDeclToCon (Hs.RecDecl n lbls)
- = RecC (toName n) (concatMap (uncurry bangToVarStrictTypes) lbls)
-
-
-
-bangToVarStrictTypes :: [Hs.Name] -> Hs.BangType -> [VarStrictType]
-bangToVarStrictTypes ns t = let (a,b) = bangToStrictType t
- in fmap (\n->(toName n,a,b)) ns
-
-bangToStrictType :: Hs.BangType -> StrictType
-bangToStrictType (Hs.BangedTy t) = (IsStrict, toType t)
-bangToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)
-bangToStrictType (Hs.UnpackedTy t) = (IsStrict, toType t)
-
-
-hsMatchesToFunD :: [Hs.Match] -> Dec
-hsMatchesToFunD [] = FunD (mkName []) [] -- errorish
-hsMatchesToFunD xs@(Hs.Match _ n _ _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs)
-
-
-hsMatchToClause :: Hs.Match -> Clause
-hsMatchToClause (Hs.Match _ _ ps _ rhs bnds) = Clause
- (fmap toPat ps)
- (hsRhsToBody rhs)
- (hsBindsToDecs bnds)
-
-
-
--- data HsRhs = HsUnGuardedRhs HsExp | HsGuardedRhs [HsGuardedRhs]
--- data HsGuardedRhs = HsGuardedRhs SrcLoc [HsStmt] HsExp
--- data Body = GuardedB [(Guard, Exp)] | NormalB Exp
--- data Guard = NormalG Exp | PatG [Stmt]
-hsRhsToBody :: Hs.Rhs -> Body
-hsRhsToBody (Hs.UnGuardedRhs e) = NormalB (toExp e)
-hsRhsToBody (Hs.GuardedRhss hsgrhs) = let fromGuardedB (GuardedB a) = a
- in GuardedB . concat
- . fmap (fromGuardedB . hsGuardedRhsToBody)
- $ hsgrhs
-
-
-
-hsGuardedRhsToBody :: Hs.GuardedRhs -> Body
-hsGuardedRhsToBody (Hs.GuardedRhs _ [] e) = NormalB (toExp e)
-hsGuardedRhsToBody (Hs.GuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)]
-hsGuardedRhsToBody (Hs.GuardedRhs _ ss e) = let ss' = fmap hsStmtToGuard ss
- (pgs,ngs) = unzip [(p,n)
- | (PatG p) <- ss'
- , n@(NormalG _) <- ss']
- e' = toExp e
- patg = PatG (concat pgs)
- in GuardedB $ (patg,e') : zip ngs (repeat e')
-
-
-
-hsStmtToGuard :: Hs.Stmt -> Guard
-hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)]
-hsStmtToGuard (Hs.Qualifier e) = NormalG (toExp e)
-hsStmtToGuard (Hs.LetStmt bs) = PatG [LetS (hsBindsToDecs bs)]
-
-
------------------------------------------------------------------------------
-
--- * ToDecs InstDecl
-instance ToDecs Hs.InstDecl where
- toDecs (Hs.InsDecl decl) = toDecs decl
- toDecs d = todo "toDec" d
-
--- * ToDecs HsDecl HsBinds
-
-instance ToDecs Hs.Decl where
--- toDecs a@(Hs.InfixDecl _ asst i ops) = [] -- HACK
--- toDecs (Hs.InlineSig _ _ _ _) = [] -- HACK
- toDecs a@(Hs.TypeSig _ ns t)
- = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns
- in xs
-
-
- toDecs a = [toDec a]
-
-collectVars e = case e of
- VarT n -> [n]
- AppT t1 t2 -> nub $ collectVars t1 ++ collectVars t2
- ForallT ns _ t -> collectVars t \\ ns
- _ -> []
-
-fixForall t = case vs of
- [] -> t
- _ -> ForallT vs [] t
- where vs = collectVars t
-
-instance ToDecs a => ToDecs [a] where
- toDecs a = concatMap toDecs a
-
-instance ToDecs Hs.Binds where
- toDecs (Hs.BDecls ds) = toDecs ds
-
-
------------------------------------------------------------------------------
View
BIN Language/Haskell/Meta/Syntax/Translate.o
Binary file not shown.
View
BIN Language/Haskell/Meta/Utils.hi
Binary file not shown.
View
522 Language/Haskell/Meta/Utils.hs
@@ -1,522 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TemplateHaskell, RankNTypes, StandaloneDeriving,
- DeriveDataTypeable, PatternGuards, FlexibleContexts, FlexibleInstances,
- TypeSynonymInstances #-}
-
--- | This module is a staging ground
--- for to-be-organized-and-merged-nicely code.
-
-module Language.Haskell.Meta.Utils where
-
-import Data.Typeable
-import Data.Generics hiding(Fixity)
-import Language.Haskell.Meta
-import System.IO.Unsafe(unsafePerformIO)
-import Language.Haskell.Exts.Pretty(prettyPrint)
-import Language.Haskell.TH.Quote
-import Language.Haskell.TH.Syntax
-import Language.Haskell.TH.Lib
-import Language.Haskell.TH.Lift (deriveLift)
-import Language.Haskell.TH.Ppr
-import Text.PrettyPrint
-import Control.Monad
-
------------------------------------------------------------------------------
-
-
-cleanNames :: (Data a) => a -> a
-cleanNames = everywhere (mkT cleanName)
- where cleanName :: Name -> Name
- cleanName n
- | isNameU n = n
- | otherwise = (mkName . nameBase) n
- isNameU :: Name -> Bool
- isNameU (Name _ (NameU _)) = True
- isNameU _ = False
-
-
--- | The type passed in must have a @Show@ instance which
--- produces a valid Haskell expression. Returns an empty
--- @String@ if this is not the case. This is not TH-specific,
--- but useful in general.
-pretty :: (Show a) => a -> String
-pretty a = case parseHsExp (show a) of
- Left _ -> []
- Right e -> prettyPrint e
-
-
-pp :: (Data a, Ppr a) => a -> String
-pp = pprint . cleanNames
-
-ppDoc :: (Data a, Ppr a) => a -> Doc
-ppDoc = text . pp
-
-
-gpretty :: (Data a) => a -> String
-gpretty = either (const []) prettyPrint . parseHsExp . gshow
-
-
-instance Show ExpQ where show = show . cleanNames . unQ
-instance Show (Q [Dec]) where show = unlines . fmap (show . cleanNames) . unQ
-instance Show DecQ where show = show . cleanNames . unQ
-instance Show TypeQ where show = show . cleanNames . unQ
-instance Show (Q String) where show = unQ
-instance Show (Q Doc) where show = show . unQ
-
-deriving instance Typeable1 Q
-deriving instance Typeable QuasiQuoter
-
-
--- | @unQ = unsafePerformIO . runQ@
-unQ :: Q a -> a
-unQ = unsafePerformIO . runQ
-
-
-nameToRawCodeStr :: Name -> String
-nameToRawCodeStr n =
- let s = showNameParens n
- in case nameSpaceOf n of
- Just VarName -> "'"++s
- Just DataName -> "'"++s
- Just TcClsName -> "''"++s
- _ -> concat ["(mkName \"", filter (/='"') s, "\")"]
- where showNameParens :: Name -> String
- showNameParens n =
- let nb = nameBase n
- in case nb of
- (c:_) | isSym c -> concat ["(",nb,")"]
- _ -> nb
- isSym :: Char -> Bool
- isSym = (`elem` "><.\\/!@#$%^&*-+?:|")
-
-
------------------------------------------------------------------------------
-
-
-(|$|) :: ExpQ -> ExpQ -> ExpQ
-infixr 0 |$|
-f |$| x = [|$f $x|]
-
-(|.|) :: ExpQ -> ExpQ -> ExpQ
-infixr 9 |.|
-g |.| f = [|$g . $f|]
-
-(|->|) :: TypeQ -> TypeQ -> TypeQ
-infixr 9 |->|
-a |->| b = appT (appT arrowT a) b
-
-
-
-unForall :: Type -> Type
-unForall (ForallT _ _ t) = t
-unForall t = t
-
-functionT :: [TypeQ] -> TypeQ
-functionT = foldl1 (|->|)
-
-mkVarT :: String -> TypeQ
-mkVarT = varT . mkName
-
-
--- | Infinite list of names composed of lowercase letters
-myNames :: [Name]
-myNames = let xs = fmap (:[]) ['a'..'z']
- ys = iterate (join (zipWith (++))) xs
- in fmap mkName (concat ys)
-
--- | Generalisation of renameTs
-renameThings _ env new acc [] = (reverse acc, env, new)
-renameThings f env new acc (t:ts) =
- let (t', env', new') = f env new t
- in renameThings f env' new' (t':acc) ts
-
--- | renameT applied to a list of types
-renameTs :: [(Name, Name)] -> [Name] -> [Type] -> [Type]
- -> ([Type], [(Name,Name)], [Name])
-renameTs = renameThings renameT
-
--- | Rename type variables in the Type according to the given association
--- list. Normalise constructor names (remove qualification, etc.)
--- If a name is not found in the association list, replace it with one from
--- the fresh names list, and add this translation to the returned list.
--- The fresh names list should be infinite; myNames is a good example.
-renameT :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name,Name)], [Name])
-renameT env [] _ = error "renameT: ran out of names!"
-renameT env (x:new) (VarT n)
- | Just n' <- lookup n env = (VarT n',env,x:new)
- | otherwise = (VarT x, (n,x):env, new)
-renameT env new (ConT n) = (ConT (normaliseName n), env, new)
-renameT env new t@(TupleT {}) = (t,env,new)
-renameT env new ArrowT = (ArrowT,env,new)
-renameT env new ListT = (ListT,env,new)
-renameT env new (AppT t t') = let (s,env',new') = renameT env new t
- (s',env'',new'') = renameT env' new' t'
- in (AppT s s', env'', new'')
-renameT env new (ForallT ns cxt t) =
- let (ns',env2,new2) = renameTs env new [] (fmap (VarT . toName) ns)
- ns'' = fmap unVarT ns'
- (cxt',env3,new3) = renamePreds env2 new2 [] cxt
- (t',env4,new4) = renameT env3 new3 t
- in (ForallT ns'' cxt' t', env4, new4)
- where
-#if MIN_VERSION_template_haskell(2,4,0)
- unVarT (VarT n) = PlainTV n
- renamePreds = renameThings renamePred
-
- renamePred env new (ClassP n ts) = let
- (ts', env', new') = renameTs env new [] ts
- in (ClassP (normaliseName n) ts', env', new')
-
- renamePred env new (EqualP t1 t2) = let
- (t1', env1, new1) = renameT env new t1
- (t2', env2, new2) = renameT env1 new1 t2
- in (EqualP t1' t2', env2, new2)
-
-#else /* !MIN_VERSION_template_haskell(2,4,0) */
- unVarT (VarT n) = n
- renamePreds = renameTs
-
-#endif /* !MIN_VERSION_template_haskell(2,4,0) */
-
--- | Remove qualification, etc.
-normaliseName :: Name -> Name
-normaliseName = mkName . nameBase
-
-applyT :: Type -> Type -> Type
-applyT (ForallT [] _ t) t' = t `AppT` t'
-applyT (ForallT (n:ns) cxt t) t' = ForallT ns cxt
- (substT [(toName n,t')] (fmap toName ns) t)
-applyT t t' = t `AppT` t'
-
-
-
-substT :: [(Name, Type)] -> [Name] -> Type -> Type
-substT env bnd (ForallT ns _ t) = substT env (fmap toName ns++bnd) t
-substT env bnd t@(VarT n)
- | n `elem` bnd = t
- | otherwise = maybe t id (lookup n env)
-substT env bnd (AppT t t') = AppT (substT env bnd t)
- (substT env bnd t')
-substT _ _ t = t
-
-
-
-
-
--- | Produces pretty code suitable
--- for human consumption.
-deriveLiftPretty :: Name -> Q String
-deriveLiftPretty n = do
- decs <- deriveLift n
- case (parseHsDecls . pprint . cleanNames) decs of
- Left e -> fail ("deriveLiftPretty: error while prettifying code: "++e)
- Right hsdecs -> return (unlines . fmap prettyPrint $ hsdecs)
-
-
-
-splitCon :: Con -> (Name,[Type])
-splitCon c = (conName c, conTypes c)
-
-
-strictTypeTy :: StrictType -> Type
-strictTypeTy (_,t) = t
-
-varStrictTypeTy :: VarStrictType -> Type
-varStrictTypeTy (_,_,t) = t
-
-
-conTypes :: Con -> [Type]
-conTypes (NormalC _ sts) = fmap strictTypeTy sts
-conTypes (RecC _ vts) = fmap varStrictTypeTy vts
-conTypes (InfixC t _ t') = fmap strictTypeTy [t,t']
-conTypes (ForallC _ _ c) = conTypes c
-
-
-conToConType :: Type -> Con -> Type
-conToConType ofType con = foldr (\a b -> AppT (AppT ArrowT a) b) ofType (conTypes con)
-
-
-
-decCons :: Dec -> [Con]
-decCons (DataD _ _ _ cons _) = cons
-decCons (NewtypeD _ _ _ con _) = [con]
-decCons _ = []
-
-
-#if MIN_VERSION_template_haskell(2,4,0)
-decTyVars :: Dec -> [TyVarBndr]
-#else /* !MIN_VERSION_template_haskell(2,4,0) */
-decTyVars :: Dec -> [Name]
-#endif /* !MIN_VERSION_template_haskell(2,4,0) */
-decTyVars (DataD _ _ ns _ _) = ns
-decTyVars (NewtypeD _ _ ns _ _) = ns
-decTyVars (TySynD _ ns _) = ns
-decTyVars (ClassD _ _ ns _ _) = ns
-decTyVars _ = []
-
-
-decName :: Dec -> Maybe Name
-decName (FunD n _) = Just n
-decName (DataD _ n _ _ _) = Just n
-decName (NewtypeD _ n _ _ _) = Just n
-decName (TySynD n _ _) = Just n
-decName (ClassD _ n _ _ _) = Just n
-decName (SigD n _) = Just n
-decName (ForeignD fgn) = Just (foreignName fgn)
-decName _ = Nothing
-
-
-foreignName :: Foreign -> Name
-foreignName (ImportF _ _ _ n _) = n
-foreignName (ExportF _ _ n _) = n
-
-
-unwindT :: Type -> [Type]
-unwindT = go
- where go :: Type -> [Type]
- go (ForallT _ _ t) = go t
- go (AppT (AppT ArrowT t) t') = t : go t'
- go _ = []
-
-
-unwindE :: Exp -> [Exp]
-unwindE = go []
- where go acc (e `AppE` e') = go (e':acc) e
- go acc e = e:acc
-
-
--- | The arity of a Type.
-arityT :: Type -> Int
-arityT = go 0
- where go :: Int -> Type -> Int
- go n (ForallT _ _ t) = go n t
- go n (AppT (AppT ArrowT _) t) =
- let n' = n+1 in n' `seq` go n' t
- go n _ = n
-
-typeToName :: Type -> Maybe Name
-typeToName t
- | ConT n <- t = Just n
- | ArrowT <- t = Just ''(->)
- | ListT <- t = Just ''[]
- | TupleT n <- t = Just $ tupleTypeName n
- | ForallT _ _ t' <- t = typeToName t'
- | otherwise = Nothing
-
--- | Randomly useful.
-nameSpaceOf :: Name -> Maybe NameSpace
-nameSpaceOf (Name _ (NameG ns _ _)) = Just ns
-nameSpaceOf _ = Nothing
-
-conName :: Con -> Name
-conName (RecC n _) = n
-conName (NormalC n _) = n
-conName (InfixC _ n _) = n
-conName (ForallC _ _ con) = conName con
-
-recCName :: Con -> Maybe Name
-recCName (RecC n _) = Just n
-recCName _ = Nothing
-
-dataDCons :: Dec -> [Con]
-dataDCons (DataD _ _ _ cons _) = cons
-dataDCons _ = []
-
-fromDataConI :: Info -> Q (Maybe Exp)
-fromDataConI (DataConI dConN ty tyConN fxty) =
- let n = arityT ty
- in replicateM n (newName "a")
- >>= \ns -> return (Just (LamE
- [ConP dConN (fmap VarP ns)]
- (TupE $ fmap VarE ns)))
-fromDataConI _ = return Nothing
-
-fromTyConI :: Info -> Maybe Dec
-fromTyConI (TyConI dec) = Just dec
-fromTyConI _ = Nothing
-
-mkFunD :: Name -> [Pat] -> Exp -> Dec
-mkFunD f xs e = FunD f [Clause xs (NormalB e) []]
-
-mkClauseQ :: [PatQ] -> ExpQ -> ClauseQ
-mkClauseQ ps e = clause ps (normalB e) []
-
------------------------------------------------------------------------------
-
--- | The strategy for producing QuasiQuoters which
--- this datatype aims to facilitate is as follows.
--- Given a collection of datatypes which make up
--- the to-be-quasiquoted languages AST, make each
--- type in this collection an instance of at least
--- @Show@ and @Lift@. Now, assuming @parsePat@ and
--- @parseExp@, both of type @String -> Q a@ (where @a@
--- is the top level type of the AST), are the pair of
--- functions you wish to use for parsing in pattern and
--- expression context respectively, put them inside
--- a @Quoter@ datatype and pass this to quasify.
-{-
-data Quoter a = Quoter
- { expQ :: (Lift a) => String -> Q a
- , patQ :: (Show a) => String -> Q a }
-
-quasify :: (Show a, Lift a) => Quoter a -> QuasiQuoter
-quasify q = QuasiQuoter
- (toExpQ (expQ q))
- (toPatQ (patQ q))
- -}
-
-toExpQ :: (Lift a) => (String -> Q a) -> (String -> ExpQ)
-toExpQ parseQ = (lift =<<) . parseQ
-
-toPatQ :: (Show a) => (String -> Q a) -> (String -> PatQ)
-toPatQ parseQ = (showToPatQ =<<) . parseQ
-
-showToPatQ :: (Show a) => a -> PatQ
-showToPatQ = either fail return . parsePat . show
-
------------------------------------------------------------------------------
-
-eitherQ :: (e -> String) -> Either e a -> Q a
-eitherQ toStr = either (fail . toStr) return
-
------------------------------------------------------------------------------
-
-
-
-
-normalizeT :: (Data a) => a -> a
-normalizeT = everywhere (mkT go)
- where go :: Type -> Type
- go (ConT n) | n == ''[] = ListT
- go (AppT (TupleT 1) t) = t
- go (ConT n) | n == ''(,) = TupleT 2
- go (ConT n) | n == ''(,,) = TupleT 3
- go (ConT n) | n == ''(,,,) = TupleT 4
- go (ConT n) | n == ''(,,,,) = TupleT 5
- go (ConT n) | n == ''(,,,,,) = TupleT 6
- go (ConT n) | n == ''(,,,,,,) = TupleT 7
- go (ConT n) | n == ''(,,,,,,,) = TupleT 8
- go (ConT n) | n == ''(,,,,,,,,) = TupleT 9
- go (ConT n) | n == ''(,,,,,,,,,) = TupleT 10
- go (ConT n) | n == ''(,,,,,,,,,,) = TupleT 11
- go (ConT n) | n == ''(,,,,,,,,,,,) = TupleT 12
- go (ConT n) | n == ''(,,,,,,,,,,,,) = TupleT 13
- go (ConT n) | n == ''(,,,,,,,,,,,,,) = TupleT 14
- go (ConT n) | n == ''(,,,,,,,,,,,,,,) = TupleT 15
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,) = TupleT 16
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,) = TupleT 17
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,) = TupleT 18
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,) = TupleT 19
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,) = TupleT 20
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,) = TupleT 21
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,) = TupleT 22
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,) = TupleT 23
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 24
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 25
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 26
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 27
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 28
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 29
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 30
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 31
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 32
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 33
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 34
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 35
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 36
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 37
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 38
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 39
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 40
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 41
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 42
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 43
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 44
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 45
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 46
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 47
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 48
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 49
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 50
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 51
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 52
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 53
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 54
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 55
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 56
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 57
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 58
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 59
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 60
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 61
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 62
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 63
- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 64
- go t = t
-
-
-
------------------------------------------------------------------------------
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
View
BIN Language/Haskell/Meta/Utils.o
Binary file not shown.
View
22 codo-notation.cabal
@@ -0,0 +1,22 @@
+name: codo-notation
+version: 0.5
+synopsis: A notation for comonads, analogous to the do-notation for monads
+-- description:
+license: BSD3
+license-file: LICENSE
+author: Dominic Orchard
+maintainer: dom.orchard@gmail.com
+-- copyright:
+category: Language
+build-type: Simple
+cabal-version: >=1.8
+
+library
+ exposed-modules: Language.Haskell.Codo
+ -- other-modules:
+ build-depends: base >= 3.5,
+ comonad >= 3,
+ uniplate > 1.6,
+ template-haskell >= 2.7,
+ haskell-src-meta >= 0.5.1
+ hs-source-dirs: src
View
0 Language/Haskell/Codo.lhs → src/Language/Haskell/Codo.lhs
File renamed without changes.

0 comments on commit 00d1d50

Please sign in to comment.
Something went wrong with that request. Please try again.