dfdb2c0 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Fix #694, converting types to source types

dfdb2c0Evan Czaplicki12 years ago

src/Type/Type.hs+198−179

compare with master

unifiedsplit

@@ -1,20 +1,22 @@

1module Type.Type where

3+import Control.Applicative ((<$>),(<*>))

4+import Control.Monad.State (StateT)

5+import qualified Control.Monad.State as State

6+import Control.Monad.Error (ErrorT, Error, liftIO)

3import qualified Data.Char as Char

7import qualified Data.Char as Char

4−import qualified Data.List as List

5import qualified Data.Map as Map

8import qualified Data.Map as Map

9+import qualified Data.Set as Set

10+import qualified Data.Traversable as Traverse (traverse)

6import qualified Data.UnionFind.IO as UF

11import qualified Data.UnionFind.IO as UF

7−import Type.PrettyPrint

8import Text.PrettyPrint as P

12import Text.PrettyPrint as P

9import System.IO.Unsafe

13import System.IO.Unsafe

10−import Control.Applicative ((<$>),(<*>))

14+

11−import Control.Monad.State (StateT, get, put, execStateT, runStateT)

12−import Control.Monad.Error (ErrorT, Error, liftIO)

13−import Data.Traversable (traverse)

14import AST.Annotation

15import AST.Annotation

15import qualified AST.PrettyPrint as PP

16import qualified AST.PrettyPrint as PP

16import qualified AST.Type as T

17import qualified AST.Type as T

17import qualified AST.Variable as Var

18import qualified AST.Variable as Var

19+import Type.PrettyPrint

20-- CONCRETE TYPES

22-- CONCRETE TYPES

@@ -354,219 +356,236 @@ instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where

354 prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty Never t

356 prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty Never t

355

357

356

358

357−extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc

359+-- CONVERT TO SOURCE TYPES

358−extraPretty t =

359− pretty Never <$> addNames t

360

361+-- TODO: Attach resulting type to the descriptor so that you

362+-- never have to do extra work, particularly nice for aliased types

363+toSrcType :: Variable -> IO T.CanonicalType

364+toSrcType variable =

365+ do addNames variable

366+ variableToSrcType variable variable

361

367

362−-- ADDING NAMES TO TYPES

363

368

364−addNames :: (Crawl t) => t -> IO t

369+variableToSrcType :: Variable -> Variable -> IO T.CanonicalType

365−addNames value =

370+variableToSrcType rootVariable variable =

366− do (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)

371+ do desc <- UF.descriptor variable

372+ srcType <- maybe (backupSrcType desc) (termToSrcType rootVariable) (structure desc)

373+ case alias desc of

374+ Nothing ->

375+ return srcType

367

376

368− let vars = map head . List.group $ List.sort rawVars

377+ Just (name, args) ->

378+ do args' <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType rootVariable tvar) args

379+ return (T.Aliased name args' srcType)

380+ where

381+ backupSrcType :: Descriptor -> IO T.CanonicalType

382+ backupSrcType desc =

383+ case name desc of

384+ Just v@(Var.Canonical _ x@(c:_))

385+ | Char.isLower c ->

386+ return (T.Var x)

387+ | otherwise ->

388+ return $ T.Type v

369

389

370− let suffix s = map (++s) (map (:[]) ['a'..'z'])

390+ _ ->

391+ error $

392+ concat

393+ [ "Problem converting the following type "

394+ , "from a type-checker type to a source-syntax type:"

395+ , P.render (pretty Never rootVariable)

396+ ]

371

397

372− let allVars = concatMap suffix $ ["","'","_"] ++ map show [ (0 :: Int) .. ]

373

398

374− let okayVars = filter (`notElem` vars) allVars

399+termToSrcType :: Variable -> Term1 Variable -> IO T.CanonicalType

400+termToSrcType rootVariable term =

401+ let go = variableToSrcType rootVariable in

402+ case term of

403+ App1 a b ->

404+ do a' <- go a

405+ b' <- go b

406+ case a' of

407+ T.App f args ->

408+ return $ T.App f (args ++ [b'])

409+ _ ->

410+ return $ T.App a' [b']

411+

412+ Fun1 a b ->

413+ T.Lambda <$> go a <*> go b

414+

415+ Var1 a ->

416+ go a

417+

418+ EmptyRecord1 ->

419+ return $ T.Record [] Nothing

420+

421+ Record1 tfields extension ->

422+ do fields' <- Traverse.traverse (mapM go) tfields

423+ let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

424+ ext' <- dealias <$> go extension

425+ return $

426+ case ext' of

427+ T.Record fs ext -> T.Record (fs ++ fields) ext

428+ T.Var _ -> T.Record fields (Just ext')

429+ _ -> error "Used toSrcType on a type that is not well-formed"

430+ where

431+ dealias :: T.CanonicalType -> T.CanonicalType

432+ dealias tipe =

433+ case tipe of

434+ T.Aliased _ args tipe' ->

435+ T.dealias args tipe'

436+ _ ->

437+ tipe

438+

439+

440+-- ADD NAMES TO TYPES

441+

442+addNames :: Variable -> IO ()

443+addNames variable =

444+ do usedNames <- getVarNames variable

445+ let freeNames = makeFreeNames usedNames

446+ State.runStateT (varAddNames variable) (NameState freeNames 0 0 0)

447+ return ()

448+

449+

450+makeFreeNames :: Set.Set String -> [String]

451+makeFreeNames usedNames =

452+ let makeName suffix =

453+ map (:suffix) ['a'..'z']

454+

455+ allNames =

456+ concatMap makeName ("" : "'" : "_" : map show [ (0 :: Int) .. ])

457+ in

458+ filter (\name -> Set.notMember name usedNames) allNames

459+

460+

461+data NameState = NameState

462+ { freeNames :: [String]

463+ , numberPrimes :: Int

464+ , comparablePrimes :: Int

465+ , appendablePrimes :: Int

466+ }

375

467

376− runStateT (crawl rename value) (okayVars, 0, 0, 0)

377

468

378− return value

469+varAddNames :: Variable -> StateT NameState IO ()

379− where

470+varAddNames var =

380− getNames desc state@(vars, a, b, c) =

471+ do desc <- liftIO (UF.descriptor var)

381− let name' = name desc in

382− case name' of

383− Just (Var.Canonical _ var) -> (name', (var:vars, a, b, c))

384− _ -> (name', state)

385−

386− rename desc state@(vars, a, b, c) =

387− case name desc of

472+ case alias desc of

388− Just var -> (Just var, state)

389 Nothing ->

473 Nothing ->

390− case flex desc of

474+ return ()

391− Is Number -> (local $ "number" ++ replicate a '\'', (vars, a+1, b, c))

392− Is Comparable -> (local $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))

393− Is Appendable -> (local $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))

394− _ -> (local $ head vars, (tail vars, a, b, c))

395− where

396− local v = Just (Var.local v)

397−

398−

399−-- CRAWLING OVER TYPES

400−

401−type CrawlState = ([String], Int, Int, Int)

402−

403

475

404−-- Code for traversing all the type data-structures and giving

476+ Just (_name, args) ->

405−-- names to the variables embedded deep in there.

477+ mapM_ (\(v,t) -> (,) v <$> varAddNames t) args

406−class Crawl t where

407− crawl :: (Descriptor -> CrawlState -> (Maybe TypeName, CrawlState))

408− -> t

409− -> StateT CrawlState IO t

410

478

479+ case structure desc of

480+ Just term ->

481+ termAddNames term

411

482

412−instance Crawl e => Crawl (Annotated a e) where

483+ Nothing ->

413− crawl nextState (A ann e) =

484+ case name desc of

414− A ann <$> crawl nextState e

485+ Just _ -> return ()

486+ Nothing ->

487+ do name' <- createName desc

488+ liftIO $ UF.modifyDescriptor var $ \desc ->

489+ desc { name = Just (Var.local name') }

415

490

416

491

417−instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where

492+termAddNames :: Term1 Variable -> StateT NameState IO ()

418− crawl nextState constraint =

493+termAddNames term =

419− let rnm = crawl nextState in

420− case constraint of

494+ case term of

421− CTrue -> return CTrue

495+ App1 a b ->

422− CSaveEnv -> return CSaveEnv

496+ do varAddNames a

423− CEqual a b -> CEqual <$> rnm a <*> rnm b

497+ varAddNames b

424− CAnd cs -> CAnd <$> crawl nextState cs

425− CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c

426− CInstance name tipe -> CInstance name <$> rnm tipe

427

498

499+ Fun1 a b ->

500+ do varAddNames a

501+ varAddNames b

428

502

429−instance Crawl a => Crawl [a] where

503+ Var1 a ->

430− crawl nextState list =

504+ varAddNames a

431− mapM (crawl nextState) list

432

505

506+ EmptyRecord1 ->

507+ return ()

433

508

434−instance (Crawl t, Crawl v) => Crawl (Scheme t v) where

509+ Record1 fields extension ->

435− crawl nextState (Scheme rqs fqs c headers) =

510+ do mapM_ varAddNames (concat (Map.elems fields))

436− let rnm = crawl nextState

511+ varAddNames extension

437− in

438− Scheme

439− <$> rnm rqs

440− <*> rnm fqs

441− <*> crawl nextState c

442− <*> return headers

443

512

444

513

445−instance Crawl t => Crawl (TermN t) where

514+createName :: (Monad m) => Descriptor -> StateT NameState m String

446− crawl nextState tipe =

515+createName desc =

447− case tipe of

516+ case flex desc of

448− PlaceHolder name ->

517+ Is Number ->

449− return (PlaceHolder name)

518+ do primes <- State.gets numberPrimes

519+ State.modify (\state -> state { numberPrimes = primes + 1 })

520+ return ("number" ++ replicate primes '\'')

450

521

451− VarN a x ->

522+ Is Comparable ->

452− VarN a <$> crawl nextState x

523+ do primes <- State.gets comparablePrimes

524+ State.modify (\state -> state { comparablePrimes = primes + 1 })

525+ return ("comparable" ++ replicate primes '\'')

453

526

454− TermN a term ->

527+ Is Appendable ->

455− TermN a <$> crawl nextState term

528+ do primes <- State.gets appendablePrimes

529+ State.modify (\state -> state { appendablePrimes = primes + 1 })

530+ return ("appendable" ++ replicate primes '\'')

456

531

532+ _ ->

533+ do names <- State.gets freeNames

534+ State.modify (\state -> state { freeNames = tail names })

535+ return (head names)

457

536

458−instance Crawl t => Crawl (Term1 t) where

459− crawl nextState term =

460− let rnm = crawl nextState in

461− case term of

462− App1 a b ->

463− App1 <$> rnm a <*> rnm b

464

537

465− Fun1 a b ->

538+-- GET ALL VARIABLE NAMES

466− Fun1 <$> rnm a <*> rnm b

467

539

468− Var1 a ->

540+getVarNames :: Variable -> IO (Set.Set String)

469− Var1 <$> rnm a

541+getVarNames var =

542+ do desc <- UF.descriptor var

470

543

471− EmptyRecord1 ->

544+ let baseSet =

472− return EmptyRecord1

545+ case name desc of

546+ Just var -> Set.singleton (Var.toString var)

547+ Nothing -> Set.empty

473

548

474− Record1 fields ext ->

549+ structureSet <-

475− Record1

550+ case structure desc of

476− <$> traverse (mapM rnm) fields

551+ Nothing -> return Set.empty

477− <*> rnm ext

552+ Just term -> getVarNamesTerm term

478

553

554+ aliasSet <-

555+ case alias desc of

556+ Nothing ->

557+ return Set.empty

479

558

480−instance Crawl a => Crawl (UF.Point a) where

559+ Just (_name, args) ->

481− crawl nextState point =

560+ do let set = Set.fromList (map fst args)

482− do desc <- liftIO $ UF.descriptor point

561+ sets <- mapM (getVarNames . snd) args

483− desc' <- crawl nextState desc

562+ return (Set.unions (set : sets))

484− liftIO $ UF.setDescriptor point desc'

485− return point

486

563

564+ return (Set.unions [ baseSet, structureSet, aliasSet ])

487

565

488−instance Crawl Descriptor where

489− crawl nextState desc =

490− do state <- get

491− let (name', state') = nextState desc state

492− structure' <- traverse (crawl nextState) (structure desc)

493− put state'

494− return $ desc { name = name', structure = structure' }

495

566

567+getVarNamesTerm :: Term1 Variable -> IO (Set.Set String)

568+getVarNamesTerm term =

569+ let go = getVarNames in

570+ case term of

571+ App1 a b ->

572+ Set.union <$> go a <*> go b

496

573

497−-- TODO: Attach resulting type to the descriptor so that you

574+ Fun1 a b ->

498−-- never have to do extra work, particularly nice for aliased types

575+ Set.union <$> go a <*> go b

499−toSrcType :: Variable -> IO T.CanonicalType

500−toSrcType var =

501− go =<< addNames var

502− where

503− go v =

504− do desc <- UF.descriptor v

505− srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)

506− case alias desc of

507− Nothing ->

508− return srcType

509

576

510− Just (name, args) ->

577+ Var1 a ->

511− do args' <- mapM (\(arg,tvar) -> (,) arg <$> go tvar) args

578+ go a

512− return (T.Aliased name args' srcType)

513

579

514− backupSrcType :: Descriptor -> IO T.CanonicalType

580+ EmptyRecord1 ->

515− backupSrcType desc =

516− case name desc of

517− Just v@(Var.Canonical _ x@(c:_))

518− | Char.isLower c ->

519− return (T.Var x)

581+ return Set.empty

520− | otherwise ->

521− return $ T.Type v

522

582

523− _ ->

583+ Record1 fields extension ->

524− error $

584+ do fieldVars <- Set.unions <$> mapM go (concat (Map.elems fields))

525− concat

585+ Set.union fieldVars <$> go extension

526− [ "Problem converting the following type "

527− , "from a type-checker type to a source-syntax type:"

528− , P.render (pretty Never var)

529− ]

530

586

531− termToSrcType :: Term1 Variable -> IO T.CanonicalType

532− termToSrcType term =

533− case term of

534− App1 a b ->

535− do a' <- go a

536− b' <- go b

537− case a' of

538− T.App f args ->

539− return $ T.App f (args ++ [b'])

540− _ ->

541− return $ T.App a' [b']

542−

543− Fun1 a b ->

544− T.Lambda <$> go a <*> go b

545−

546− Var1 a ->

547− go a

548−

549− EmptyRecord1 ->

550− return $ T.Record [] Nothing

551−

552− Record1 tfields extension ->

553− do fields' <- traverse (mapM go) tfields

554− let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

555− ext' <- dealias <$> go extension

556− return $

557− case ext' of

558− T.Record fs ext -> T.Record (fs ++ fields) ext

559− T.Var _ -> T.Record fields (Just ext')

560− _ -> error "Used toSrcType on a type that is not well-formed"

561−

562− dealias :: T.CanonicalType -> T.CanonicalType

563− dealias tipe =

564− case tipe of

565− T.Aliased _ args tipe' ->

566− T.dealias args tipe'

567− _ ->

568− tipe

569

587

588+-- COLLECT APPLICATIONS

570

589

571data AppStructure

590data AppStructure

572 = List Variable

591 = List Variable