haskell-src-meta 0.0.3.1 → 0.0.4

raw patch · 7 files changed

+573/−82 lines, 7 filesdep ~haskell-src-extsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: haskell-src-exts

API changes (from Hackage documentation)

Files

• Setup too large to diff
• haskell-src-meta.cabal +6/−3
• src/Language/Haskell/Meta/Parse.hs +30/−58
• src/Language/Haskell/Meta/QQ/BF.hs +183/−0
• src/Language/Haskell/Meta/QQ/HsHere.hs +106/−0
• src/Language/Haskell/Meta/QQ/SKI.hs +155/−0
• src/Language/Haskell/Meta/Syntax/Translate.hs +93/−21

file too large to diff

@@ -1,5 +1,5 @@ name:               haskell-src-meta-version:            0.0.3.1+version:            0.0.4 cabal-version:      >= 1.6 build-type:         Simple license:            BSD3@@ -14,7 +14,7 @@                     to template-haskell abstract syntax isn't 100% complete yet.  library-  build-Depends:      base == 4.*, containers, haskell-src-exts == 0.4.*,+  build-Depends:      base == 4.*, containers, haskell-src-exts == 1.0.*,                       packedstring, template-haskell, pretty, syb   extensions:         TemplateHaskell, QuasiQuotes,                       RankNTypes, StandaloneDeriving,@@ -32,4 +32,7 @@                       Language.Haskell.Meta.Utils,                       Language.Haskell.Meta.QQ.Hs,                       Language.Haskell.Meta.QQ.Here,-                      Language.Haskell.Meta.QQ.Vixey+                      Language.Haskell.Meta.QQ.HsHere,+                      Language.Haskell.Meta.QQ.Vixey,+                      Language.Haskell.Meta.QQ.BF,+                      Language.Haskell.Meta.QQ.SKI

@@ -14,6 +14,8 @@ import Language.Haskell.TH.Syntax import Language.Haskell.Meta.Syntax import qualified Language.Haskell.Exts.Syntax as Hs+import Language.Haskell.Exts.Extension+import Language.Haskell.Exts.Fixity import Language.Haskell.Exts.Parser import Language.Haskell.Exts.Pretty @@ -34,77 +36,50 @@ parseDecs :: String -> Either String [Dec] parseDecs  = either Left (Right . fmap toDec) . parseHsDecls - ----------------------------------------------------------------------------- --- * haskell-src-exts--parseFile :: FilePath -> IO (ParseResult Hs.Module)-parseFile fp = readFile fp >>= (return . parseFileContentsWithMode (ParseMode fp))---parseFileContents :: String -> ParseResult Hs.Module-parseFileContents = parseFileContentsWithMode defaultParseMode---parseFileContentsWithMode :: ParseMode -> String -> ParseResult Hs.Module-parseFileContentsWithMode p rawStr = parseModuleWithMode p (unlines $ map f $ lines rawStr)-  where f ('#':_) = ""-        f x = x-+myDefaultParseMode :: ParseMode+myDefaultParseMode = ParseMode+  {parseFilename = []+  ,extensions = myDefaultExtensions+  ,ignoreLanguagePragmas = False+  ,fixities = baseFixities} ------------------------------------------------------------------------------+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 s =-  case parseModule s of-    ParseOk m -> Right m-    ParseFailed loc e ->-      let line = Hs.srcLine loc - 1-      in Left (unlines [show line,show loc,e])-+parseHsModule = parseResultToEither . parseModuleWithMode myDefaultParseMode  parseHsDecls :: String -> Either String [Hs.Decl]-parseHsDecls s =-  let s' = unlines [pprHsModule (emptyHsModule "Main"), s]-  in case parseModule s' of-      ParseOk m -> Right (moduleDecls m)-      ParseFailed loc e ->-        let line = Hs.srcLine loc - 1-        in Left (unlines [show line,show loc,e])+parseHsDecls = either Left (Right . moduleDecls)+  . parseResultToEither . parseModuleWithMode myDefaultParseMode   parseHsType :: String -> Either String Hs.Type-parseHsType s =-  case parseHsDecls ("zomg::\n" ++ (unlines-                      . fmap ("  "++) . lines $ s ++"\n  =()")) of-    Left err -> Left err-    Right xs ->-      case [ t | Hs.PatBind _ _ (Just t) _ _ <- xs] of-        []    -> Left "invalid type"-        (t:_) -> Right t+parseHsType = parseResultToEither . parseTypeWithMode myDefaultParseMode   parseHsExp :: String -> Either String Hs.Exp-parseHsExp s =-  case parseHsDecls ("main =\n" ++ (unlines . fmap ("  "++) . lines $ s)) of-    Left err -> Left err-    Right xs ->-      case [ e | Hs.PatBind _ _ _ (Hs.UnGuardedRhs e) _ <- xs] of-        []    -> Left "invalid expression"-        (e:_) -> Right e-+parseHsExp = parseResultToEither . parseExpWithMode myDefaultParseMode  parseHsPat :: String -> Either String Hs.Pat-parseHsPat s =-  case parseHsDecls ("("++(filter (/='\n') s)++")=()") of-    Left err -> Left err-    Right xs ->-      case [ p | Hs.PatBind _ p _ _ _ <- xs] of-        []    -> Left "invalid pattern"-        (p:_) -> Right p-+parseHsPat = parseResultToEither . parsePatWithMode myDefaultParseMode  pprHsModule :: Hs.Module -> String pprHsModule = prettyPrint@@ -113,14 +88,11 @@ 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 =

@@ -0,0 +1,183 @@+{-# LANGUAGE BangPatterns, TemplateHaskell #-}++module Language.Haskell.Meta.QQ.BF (+   bf,bf2,bfHelloWorld+) where++import Language.Haskell.Meta+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax++import Data.Char+import Data.IntMap(IntMap,(!))+import qualified Data.IntMap as IM+++bf :: QuasiQuoter+bf = QuasiQuoter bfExpQ bfPatQ++bf2 :: QuasiQuoter+bf2 = QuasiQuoter bf2ExpQ bfPatQ++bf2ExpQ :: String -> ExpQ+bf2ExpQ s = [|eval (parse s)|]++bfExpQ :: String -> ExpQ+bfExpQ s = [|eval_ (parse s)|]++bfPatQ :: String -> PatQ+bfPatQ s = do+  let p = (parsePat+            . show+              . parse) s+  case p of+    Left e -> fail e+    Right p -> return p++instance Lift Bf where+  lift Inp = [|Inp|]+  lift Out = [|Out|]+  lift Inc = [|Inc|]+  lift Dec = [|Dec|]+  lift MovL = [|MovL|]+  lift MovR = [|MovR|]+  lift (While xs) = [|While $(lift xs)|]++type Ptr = Int+newtype Mem = Mem (IntMap Int) deriving (Show)++data Bf = Inp+        | Out+        | Inc+        | Dec+        | MovL+        | MovR+        | While [Bf]+  deriving (Eq,Ord,Read,Show)++data Status = D Ptr Mem+            | W Int Status+            | R (Int -> Status)++-- ghci> exec (parse helloWorld)+-- Hello World!+-- (4,Mem (fromList [(0,0),(1,87),(2,100),(3,33),(4,10)]))+bfHelloWorld :: String+bfHelloWorld = "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>."++eval_ :: [Bf] -> (String -> String)+eval_ is = go (run 0 initMem is)+  where go (D p m)    _    = []+        go (W n s)    cs   = chr n : go s cs+        go (R cont)   []   = "*** Exception: bf blocked on input"+        go (R cont) (c:cs) = go ((cont . ord) c) cs++eval :: [Bf] -> String -> (String, (Ptr, Mem))+eval is = go [] (run 0 initMem is)+  where go acc (D p m)    _    = (reverse acc, (p, m))+        go acc (W n s)    cs   = go (chr n:acc) s cs+        go _   (R cont)   []   = ("*** Exception: bf blocked on input",(-1, Mem IM.empty))+        go acc (R cont) (c:cs) = go acc ((cont . ord) c) cs++exec :: [Bf] -> IO (Ptr, Mem)+exec is = go (run 0 initMem is)+  where go (D p m)  = return (p, m)+        go (W n s)  = putChar (chr n) >> go s+        go (R cont) = go . cont . ord =<< getChar++run :: Ptr -> Mem -> [Bf] -> Status+run dp m is = step dp m is (\dp m -> D dp m)++step :: Ptr -> Mem -> [Bf] -> (Ptr -> Mem -> Status) -> Status+step dp m   []          k = k dp m+step dp m (Inc:is)      k = step dp (inc dp m) is k+step dp m (Dec:is)      k = step dp (dec dp m) is k+step dp m (MovL:is)     k = step (dp-1) m is k+step dp m (MovR:is)     k = step (dp+1) m is k+step dp m (Inp:is)      k = R (\c -> step dp (wr m dp c) is k)+step dp m (Out:is)      k = W (rd m dp) (step dp m is k)+step dp m (While xs:is) k = let go dp m = if rd m dp == 0+                                            then step dp m is k+                                            else step dp m xs go+                            in go dp m++initMem :: Mem+initMem = Mem IM.empty++inc :: Ptr -> (Mem -> Mem)+dec :: Ptr -> (Mem -> Mem)+rd :: Mem -> Ptr -> Int+wr :: Mem -> Ptr -> Int -> Mem+upd :: Mem -> Ptr -> (Int -> Int) -> Mem+inc p m = upd m p (+1)+dec p m = upd m p (subtract 1)+rd (Mem m) p = maybe 0 id (IM.lookup p m)+wr (Mem m) p n = Mem (IM.insert p n m)+upd m p f = wr m p (f (rd m p))++parse :: String -> [Bf]+parse s = go 0 [] s (\_ xs _ -> xs)+  where go :: Int -> [Bf] -> String+          -> (Int -> [Bf] -> String -> o) -> o+        go !n acc   []     k = k n (reverse acc) []+        go !n acc (',':cs) k = go (n+1) (Inp:acc) cs k+        go !n acc ('.':cs) k = go (n+1) (Out:acc) cs k+        go !n acc ('+':cs) k = go (n+1) (Inc:acc) cs k+        go !n acc ('-':cs) k = go (n+1) (Dec:acc) cs k+        go !n acc ('<':cs) k = go (n+1) (MovL:acc) cs k+        go !n acc ('>':cs) k = go (n+1) (MovR:acc) cs k+        go !n acc ('[':cs) k = go (n+1) [] cs (\n xs cs ->+                                go n (While xs:acc) cs k)+        go !n acc (']':cs) k = k (n+1) (reverse acc) cs+        go !n acc (c  :cs) k = go n acc cs k++++test0 = do+  a <- readFile "prime.bf"+  return (parse a)++++++++{-+data Bf = Inp+        | Out+        | Inc+        | Dec+        | MovL+        | MovR+        | While [Bf]+        | Error String+  deriving (Eq,Ord,Read,Show)++parse :: String -> [Bf]+parse s = let p n s = case go n [] s of+                        (_,xs,[]) -> xs+                        (n,xs, s) -> xs ++ p n s+          in p 0 s+  where go :: Int -> [Bf] -> [Char] -> (Int, [Bf], String)+        go !n acc   []     = (n, reverse acc, [])+        go !n acc (',':cs) = go (n+1) (Inp:acc) cs+        go !n acc ('.':cs) = go (n+1) (Out:acc) cs+        go !n acc ('+':cs) = go (n+1) (Inc:acc) cs+        go !n acc ('-':cs) = go (n+1) (Dec:acc) cs+        go !n acc ('<':cs) = go (n+1) (MovL:acc) cs+        go !n acc ('>':cs) = go (n+1) (MovR:acc) cs+        go !n acc ('[':cs) = case go (n+1) [] cs of+                                (n,xs,cs) -> go n (While xs:acc) cs+        go !n acc (']':cs) = (n+1, reverse acc, cs)+        go !n acc (c  :cs) = (n+1, [Error ("go error: char "++show n+                                    ++" illegal character: "++show c)], [])+-}++++++

@@ -0,0 +1,106 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}++module Language.Haskell.Meta.QQ.HsHere (here) where++import Language.Haskell.Meta+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Language.Haskell.Meta.Utils+import Text.ParserCombinators.ReadP+import Data.Typeable(Typeable)+import Data.Generics(Data)++data Here+  = CodeH Exp+  | TextH String+  | ManyH [Here]+  deriving (Eq,Show,Data,Typeable)++here :: QuasiQuoter+here = QuasiQuoter+        {quoteExp = hereExpQ+        ,quotePat = herePatQ}++instance Lift Here+  where lift = liftHere++liftHere :: Here -> ExpQ+liftHere (TextH s)  = (litE . stringL) s+liftHere (CodeH e)  = [|show $(return e)|]+liftHere (ManyH hs) = [|concat $(listE (fmap liftHere hs))|]+++hereExpQ :: String -> ExpQ+hereExpQ s = case run s of+              [] -> fail "here: parse error"+              e:_ -> lift (cleanNames e)++herePatQ :: String -> PatQ+herePatQ s = do+  e <- hereExpQ s+  let p = (parsePat+            . pprint+              . cleanNames) e+  case p of+    Left e -> fail e+    Right p -> return p++run :: String -> [Here]+run = fst . parse++parse :: String -> ([Here], String)+parse = runP hereP++hereP :: ReadP Here+hereP = (ManyH . mergeTexts)+  `fmap` many (oneP =<< look)++mergeTexts :: [Here] -> [Here]+mergeTexts [] = []+mergeTexts (TextH s:TextH t:hs)+  = mergeTexts (TextH (s++t):hs)+mergeTexts (h:hs) = h : mergeTexts hs++oneP :: String -> ReadP Here+oneP s+  | [] <- s         = pfail+  | '\\':'$':s <- s = do skip 2+                         (TextH . ("\\$"++))+                          `fmap` munch (/='\\')+  | '$':'(':s <- s  = skip 2 >> go 1 [] s+  | c:s <- s        = do skip 1+                         (TextH . (c:))+                          `fmap` munch (not.(`elem`"\\$"))+  where go _ acc  []         = return (TextH (reverse acc))+        go 1 []  (')':_) = skip 1 >> return (TextH "$()")+        go 1 acc (')':_) = do skip (1 + length acc)+                              let s = reverse acc+                              either (const (return+                                              (TextH s)))+                                     (return . CodeH)+                                     (parseExp s)+        go n acc ('(':s)     = go (n+1) ('[':acc) s+        go n acc (')':s)     = go (n-1) (']':acc) s+        go n acc (c:s)       = go n (c:acc) s+++runP :: ReadP a -> String -> ([a], String)+runP p s = case readP_to_S p s of+              [] -> ([],[])+              xs -> mapfst (:[]) (last xs)+  where mapfst f (a,b) = (f a,b)+skip :: Int -> ReadP ()+skip n = count n get >> return ()+lexemeP :: ReadP a -> ReadP a+lexemeP p = p >>= \x -> skipSpaces >> return x+nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a)+nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p)+parensP  = between oparenP cparenP+bracksP  = between oparenP cparenP+oparenP  = char '('+cparenP  = char ')'+obrackP  = char '['+cbrackP  = char ']'+

@@ -0,0 +1,155 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}++module Language.Haskell.Meta.QQ.SKI (SKI(..),ski) where++import Language.Haskell.Meta+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Language.Haskell.Meta.Utils+import Text.ParserCombinators.ReadP+import Data.Typeable(Typeable)+import Data.Generics(Data)+import Text.PrettyPrint(render)++data SKI = S | K | I | E Exp | SKI :$ SKI+  deriving (Eq,Data,Typeable)++run :: String -> [SKI]+run = fmap eval . fst . parse++-- I x = x+-- K x y = x+-- S x y z = (x z) (y z)+eval :: SKI -> SKI+eval (I :$ x)               = eval x+eval ((K :$ x) :$ y)        = eval x+eval (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))+eval (E e :$ E e')          = E (unQ[|$(return e) $(return e')|])+eval (x :$ y)               = eval0 ((eval x) :$ (eval y))+eval  x                     = x+eval0 (I :$ x)               = eval x+eval0 ((K :$ x) :$ y)        = eval x+eval0 (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))+eval0 (E e :$ E e')          = E (unQ[|$(return e) $(return e')|])+eval0  x                     = x++ski :: QuasiQuoter+ski = QuasiQuoter+        {quoteExp = skiExpQ+        ,quotePat = skiPatQ}++instance Lift SKI where+  lift = liftSKI++liftSKI (E e) = return e+liftSKI a     = go a+  where go S = [|S|]+        go K = [|K|]+        go I = [|I|]+        go (E e) = [|E e|]+        go (x:$y) = [|$(go x) :$ $(go y)|]++instance Show SKI where+        showsPrec p (S) = showString "S"+        showsPrec p (K) = showString "K"+        showsPrec p (I) = showString "I"+        showsPrec p (E x1)+          = showParen (p > 10)+              (showString (render (ppDoc x1)))+        showsPrec p ((:$) x1 x2)+          = showParen (p > 10)+              (showsPrec 11 x1 . (showString " :$ " . showsPrec 10 x2))++skiExpQ :: String -> ExpQ+skiExpQ s = case run s of+              [] -> fail "ski: parse error"+              e:_ -> lift (cleanNames e)++skiPatQ :: String -> PatQ+skiPatQ s = do+  e <- skiExpQ s+  let p = (parsePat+            . pprint+              . cleanNames) e+  case p of+    Left e -> fail e+    Right p -> return p++-- ghci> parse "S(SS)IK(SK)"+-- ([(((S :$ (S :$ S)) :$ I) :$ K) :$ (S :$ K)],"")+parse :: String -> ([SKI], String)+parse = runP skiP++skiP :: ReadP SKI+skiP = nestedP parensP+  (let go a = (do b <- lexemeP (oneP <++ skiP)+                  go (a:$b)) <++ return a+    in lexemeP (go =<< lexemeP oneP))++oneP :: ReadP SKI+oneP = nestedP parensP+  (lexemeP (choice [sP+                   ,kP+                   ,iP+                   ,spliceP =<< look+                   ]))++spliceP :: String -> ReadP SKI+spliceP s+  | '[':s <- s = skip 1 >> go 1 [] s+  | otherwise  = pfail+  where go _ _   []         = pfail+        go 1 acc (']':_) = do skip (1 + length acc)+                              either (const pfail)+                                     (return . E)+                                     (parseExp (reverse acc))+        go n acc ('[':s)     = go (n+1) ('[':acc) s+        go n acc (']':s)     = go (n-1) (']':acc) s+        go n acc (c:s)       = go n (c:acc) s++++sP = (char 's' +++ char 'S') >> return S+kP = (char 'k' +++ char 'K') >> return K+iP = (char 'i' +++ char 'I') >> return I++runP :: ReadP a -> String -> ([a], String)+runP p s = case readP_to_S p s of+              [] -> ([],[])+              xs -> mapfst (:[]) (last xs)+  where mapfst f (a,b) = (f a,b)+skip :: Int -> ReadP ()+skip n = count n get >> return ()+lexemeP :: ReadP a -> ReadP a+lexemeP p = p >>= \x -> skipSpaces >> return x+nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a)+nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p)+parensP  = between oparenP cparenP+bracksP  = between oparenP cparenP+oparenP  = char '('+cparenP  = char ')'+obrackP  = char '['+cbrackP  = char ']'+++++{-+import Prelude hiding (($))+data Komb = S (Maybe (Komb, Maybe Komb)) | K (Maybe Komb) deriving Show+S Nothing $ x = S (Just (x, Nothing))+S (Just (x, Nothing)) $ y = S (Just (x, Just y))+S (Just (x, Just y)) $ z = x $ z $ (y $ z)+K Nothing $ x = K (Just x)+K (Just x) $ y = y+q x = x $ (c $ k) $ k $ k $ s+ where s = S Nothing+       k = K Nothing+       c = s $ (b $ b $ s) $ k $ k+       b = s $ (k $ s) $ k+-}+++

@@ -102,7 +102,7 @@   toName Hs.UnitCon = '()   toName Hs.ListCon = '[]   toName Hs.FunCon  = ''(->)-  toName (Hs.TupleCon n)+  toName (Hs.TupleCon _ n)     | n<2 = '()     | otherwise =       let x = maybe [] (++".") (nameModule '())@@ -184,6 +184,7 @@   + instance ToExp Hs.Exp where {- data HsExp@@ -303,16 +304,19 @@ instance ToType Hs.Type where   toType (Hs.TyForall tvbM cxt t) = ForallT (maybe [] (fmap toName) tvbM) (fmap toType 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 a@(Hs.TyPred _) = error $ errorMsg "toType" a-+  toType (Hs.TyParen t) = toType t   -- XXX: need to wrap the name in parens!-  toType (Hs.TyInfix a qn b) = foldAppT (ConT . toName $ qn) (fmap toType [a,b])+  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 @@ -370,22 +374,48 @@ -}  instance ToDec Hs.Decl where-  toDec (Hs.TypeDecl _ n ns t) = TySynD (toName n) (fmap toName ns) (toType t)-  toDec a@(Hs.DataDecl  _ dOrN cxt n ns qcds qns) = error $ errorMsg "toDec" a-{--data HsQualConDecl-    = HsQualConDecl SrcLoc -        [HsTyVarBind] HsContext-         HsConDecl--}-{--    case dOrN of-      DataType -> DataD-                    (fmap toType cxt)-                    (toName n)-                    (fmap toName ns)-      NewType  ->--}+  toDec (Hs.TypeDecl _ n ns t)+    = TySynD (toName n) (fmap toName ns) (toType t)+++  toDec a@(Hs.DataDecl  _ dOrN cxt n ns qcds qns)+    = case dOrN of+        Hs.DataType -> DataD (fmap toType cxt)+                              (toName n)+                              (fmap toName ns)+                              (fmap qualConDeclToCon qcds)+                              (fmap (toName . fst) qns)+        Hs.NewType  -> let qcd = case qcds of+                                  x:_ -> x+                                  _   -> error "toDec: Newtype has no constructors!"+                        in NewtypeD (fmap toType cxt)+                                    (toName n)+                                    (fmap toName 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)++   toDec a@(Hs.GDataDecl _ dOrN cxt n ns kM gadtDecs _) = error $ errorMsg "toDec" a   toDec a@(Hs.TypeFamDecl _ n ns kM)                   = error $ errorMsg "toDec" a   toDec a@(Hs.DataFamDecl _ cxt n ns kM)               = error $ errorMsg "toDec" a@@ -399,7 +429,12 @@   toDec a@(Hs.DerivDecl _ cxt qn ts)                   = error $ errorMsg "toDec" a     toDec a@(Hs.DefaultDecl _ ts)                        = error $ errorMsg "toDec" a   toDec a@(Hs.SpliceDecl _ s)                          = error $ errorMsg "toDec" a-  toDec a@(Hs.TypeSig _ ns t)                          = error $ errorMsg "toDec" a+  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] | ...@@ -417,6 +452,43 @@   toDec a@(Hs.ForImp _ cconv safe str n t)             = error $ errorMsg "toDec" a   toDec a@(Hs.ForExp _ cconv      str n t)             = error $ errorMsg "toDec" a ++++-- data Hs.Decl = ... | Hs.SpliceDecl Hs.SrcLoc Hs.Splice | ...+-- data Hs.Splice = Hs.IdSplice String | Hs.ParenSplice Hs.Exp+++++++++++qualConDeclToCon :: Hs.QualConDecl -> Con+qualConDeclToCon (Hs.QualConDecl _ [] [] cdecl) = conDeclToCon cdecl+qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (fmap toName ns)+                                                    (fmap toType 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