[add support for CTYPE pragma
John Meacham <john@repetae.net>**20120311040440
 Ignore-this: 3df9d37a3d057f01809bd2aa50baad42
] hunk ./src/DataConstructors.hs 122
-data AliasType = NotAlias | ErasedAlias | RecursiveAlias
+data AliasType = ErasedAlias | RecursiveAlias
hunk ./src/DataConstructors.hs 133
+    | DataAlias !AliasType
hunk ./src/DataConstructors.hs 145
-    conAlias     :: !AliasType,   -- whether this is a simple alias and has no tag of its own.
hunk ./src/DataConstructors.hs 147
-    conChildren  :: DataFamily
+    conChildren  :: DataFamily,
+    conCTYPE     :: Maybe ExtType -- external type
hunk ./src/DataConstructors.hs 188
-    conAlias     = NotAlias,
hunk ./src/DataConstructors.hs 189
+    conCTYPE     = Nothing,
hunk ./src/DataConstructors.hs 421
+    f seen e@(ELit LitCons { litName = c }) | Just (conCTYPE -> Just et) <- getConstructor c dataTable = do
+        res <- g seen e
+        return $ case res of
+            ExtTypeRaw _ -> ExtTypeRaw et
+            ExtTypeBoxed b t _ -> ExtTypeBoxed b t et
+            ExtTypeVoid -> ExtTypeVoid
hunk ./src/DataConstructors.hs 548
-        Constructor { conAlias = ErasedAlias, conOrigSlots = [SlotNormal sl] } <- getConstructor x dataTable
+        Constructor { conChildren = DataAlias ErasedAlias, conOrigSlots = [SlotNormal sl] } <- getConstructor x dataTable
hunk ./src/DataConstructors.hs 562
---    f decl@HsNewTypeDecl {} = g decl
hunk ./src/DataConstructors.hs 591
-        dt decl (if nn `elem` newtypeLoopBreakers then RecursiveAlias else ErasedAlias) cs
+        dt decl (if nn `elem` newtypeLoopBreakers then DataAlias RecursiveAlias else DataAlias ErasedAlias) cs
hunk ./src/DataConstructors.hs 593
-    f decl@HsDataDecl { hsDeclCons = cs } = dt decl NotAlias cs
+    f decl@HsDataDecl { hsDeclCons = cs } = dt decl DataNone cs
hunk ./src/DataConstructors.hs 595
-    dt decl NotAlias cs@(_:_:_) | all null (map hsConDeclArgs cs) = do
-        let virtualCons'@(fc:_) = map (makeData NotAlias typeInfo) cs
-            typeInfo@(theType,_,_) = makeType decl
+    dt decl DataNone cs@(_:_:_) | all null (map hsConDeclArgs cs) = do
+        let virtualCons'@(fc:_) = map (makeData DataNone typeInfo) cs
+            typeInfo@(theType,_,_) = makeType decl (hsDeclCTYPE decl)
hunk ./src/DataConstructors.hs 620
-            typeInfo@(theType,_,_) = makeType decl
+            typeInfo@(theType,_,_) = makeType decl (hsDeclCTYPE decl)
hunk ./src/DataConstructors.hs 651
-            conAlias = alias
+            conChildren = alias
hunk ./src/DataConstructors.hs 687
-                    case (conAlias con,slotTypes fullDataTable dc te) of
-                        (ErasedAlias,[nt]) -> g e nt
+                    case (conChildren con,slotTypes fullDataTable dc te) of
+                        (DataAlias ErasedAlias,[nt]) -> g e nt
hunk ./src/DataConstructors.hs 703
-    makeType decl = (theType,theTypeArgs,theTypeExpr) where
+    makeType decl ct = (theType,theTypeArgs,theTypeExpr) where
hunk ./src/DataConstructors.hs 710
-            conName = theTypeName,
-            conType = theKind,
+            conCTYPE     = fmap (ExtType . packString) ct,
+            conExpr      = foldr ($) theTypeExpr (map ELam theTypeArgs),
+            conInhabits  = if theTypeFKind == eStar then s_Star else s_Hash,
+            conName      = theTypeName,
hunk ./src/DataConstructors.hs 715
-            conExpr = foldr ($) theTypeExpr (map ELam theTypeArgs),
-            conInhabits = if theTypeFKind == eStar then s_Star else s_Hash,
-            conVirtual = Nothing,
-            conChildren = undefined
+            conType      = theKind,
+            conVirtual   = Nothing
hunk ./src/DataConstructors.hs 731
-    | ErasedAlias <- conAlias mc = ELam var (EVar var)
-    | RecursiveAlias <- conAlias mc = let var' = var { tvrType = st } in ELam var' (prim_unsafeCoerce (EVar var') typ)
+    | DataAlias ErasedAlias <- conChildren mc = ELam var (EVar var)
+    | DataAlias RecursiveAlias <- conChildren mc = let var' = var { tvrType = st } in ELam var' (prim_unsafeCoerce (EVar var') typ)
hunk ./src/DataConstructors.hs 809
-    c con = vcat [t,e,cs,al,vt,ih,ch] where
+    c con = vcat [t,e,cs,vt,ih,ch,mc] where
hunk ./src/DataConstructors.hs 813
-        al = text "alias:"    <+> tshow conAlias
hunk ./src/DataConstructors.hs 816
+        mc = text "CTYPE:"    <+> tshow conCTYPE
hunk ./src/E/FromHs.hs 791
-        case conAlias patCons of
-            ErasedAlias -> f p
+        case conChildren patCons of
+            DataAlias ErasedAlias -> f p
hunk ./src/E/FromHs.hs 988
-    f ECase { eCaseScrutinee = e, eCaseAlts =  ((Alt (LitCons { litName = n, litArgs = [v], litType = t }) z):_) } | alias == ErasedAlias = f (eLet v e z) where
-        Identity Constructor { conAlias = alias } = getConstructor n dataTable
-    f ECase { eCaseScrutinee = e, eCaseAlts =  ((Alt (LitCons { litName = n, litArgs = [v], litType = t }) z):_) } | alias == RecursiveAlias = f $ eLet v (prim_unsafeCoerce e (getType v)) z where
-        Identity Constructor { conAlias = alias } = getConstructor n dataTable
+    f ECase { eCaseScrutinee = e, eCaseAlts = ((Alt (LitCons { litName = n, litArgs = [v], litType = t }) z):_) } | alias == DataAlias ErasedAlias = f (eLet v e z) where
+        Identity Constructor { conChildren = alias } = getConstructor n dataTable
+    f ECase { eCaseScrutinee = e, eCaseAlts =  ((Alt (LitCons { litName = n, litArgs = [v], litType = t }) z):_) } | alias == DataAlias RecursiveAlias = f $ eLet v (prim_unsafeCoerce e (getType v)) z where
+        Identity Constructor { conChildren = alias } = getConstructor n dataTable
hunk ./src/E/PrimDecode.hs 10
-import Data.Monoid(Monoid(..))
hunk ./src/FrontEnd/HsParser.y 305
+mCTYPE :: { Maybe String }
+    :  PRAGMACTYPE STRING PRAGMAEND  { Just $2 }
+    |                                { Nothing }
+
hunk ./src/FrontEnd/HsParser.y 326
-      | 'newtype' ctype srcloc '=' constr deriving
-                      {% checkDataHeader $2 `thenP` \(cs,c,t) ->
-                         returnP hsNewTypeDecl { hsDeclSrcLoc = $3, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclCons = [$5], hsDeclDerives = $6} }
+      | 'newtype' mCTYPE ctype srcloc '=' constr deriving
+                      {% checkDataHeader $3 `thenP` \(cs,c,t) ->
+                         returnP hsNewTypeDecl { hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclCons = [$6], hsDeclDerives = $7, hsDeclCTYPE = $2} }
hunk ./src/FrontEnd/HsSyn.hs 108
+    hsDeclCTYPE = Nothing,
hunk ./src/FrontEnd/HsSyn.hs 142
+        hsDeclCTYPE    :: Maybe String,
hunk ./src/Grin/FromE.hs 307
-    | conAlias cons /= NotAlias = error $ "Alias still exists: " ++ show v
+    | isDataAlias (conChildren cons) = error $ "Alias still exists: " ++ show v
hunk ./src/Grin/FromE.hs 318
+isDataAlias x = case x of
+    DataAlias {} -> True
+    _ -> False
+
hunk ./src/Grin/FromE.hs 699
-        | conAlias cons /= NotAlias = error $ "Alias still exists: " ++ show v
+        | isDataAlias (conChildren cons) = error $ "Alias still exists: " ++ show v